• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

TCMB-Döviz Kuru aldırma

Kur Alma güncellendi.

Merhaba arkadaşlar daha önceden siteden indirmiş olduğum ve çok işime yarayan merkez bankası döviz kurlarını alma excel programını son zamanlarda merkez bankası sistemini değiştirdiği için kullamıyordum fakat güncellemeyi yaptım artık tekrar aktif şekilde kullanabiliriz. İyi günler Dosya ektedir.
 

Ekli dosyalar

Emeğinize için teşekkür ederim. Mutlaka işine yarayacak arkadaşlar olacaktır.
 
Döviz sorgulaması yaptığınızda karşınıza aşağıdaki gibi uyarı gelir.

İlgili güne ait kur saat 15:30'da kesinleşir. Bu sebeple uygulamada 1 önceki güne ait kur bilgisi kullanılmaktadır.

15.10.2014 Günü Saat 15:30'da Belirlenen Gösterge Niteliğindeki Türkiye Cumhuriyet Merkez Bankası Kurları
Genişletmek için tıkla ...
 
Diğer döviz türlerinin eklendiği bir örnek versiyon var mıdır?
 
Arkadaşlar merhaba.. İlişikteki excel dosyada kurları otomatik olarak çekebiliyordum. Ancak artık çekemiyorum. Bu konuda "el atabilecek" bir arkadaş var mıdır yardım rica etsem? Sorgula butonuna bastığımda güncel kurların gelmesi lazım..
Dosya: https://yadi.sk/i/0XuDU42Wc9nuQ indirebilirsiniz.
Mail için cemberkan@gmail.com a gönderebilirseniz sevinirim. Çok teşekkürler şimdiden...
 
Bir ayrıntı var..

Merhabalar tekrar..
Benim eski listemde USD KUR,EURO KUR ve USD/EURO paritesi var.
Pariteyi nasıl ekleyebiliriz?

cemberkan' Alıntı:
Arkadaşlar merhaba.. İlişikteki excel dosyada kurları otomatik olarak çekebiliyordum. Ancak artık çekemiyorum. Bu konuda "el atabilecek" bir arkadaş var mıdır yardım rica etsem? Sorgula butonuna bastığımda güncel kurların gelmesi lazım..
Dosya: https://yadi.sk/i/0XuDU42Wc9nuQ indirebilirsiniz.
Mail için cemberkan@gmail.com a gönderebilirseniz sevinirim. Çok teşekkürler şimdiden...
Genişletmek için tıkla ...
 
Mümkünse destek talep ediyorum. Kimse yok mu???
Arkadaşlar merhaba.. İlişikteki excel dosyada kurları otomatik olarak çekebiliyordum. Ancak artık çekemiyorum. Bu konuda "el atabilecek" bir arkadaş var mıdır yardım rica etsem? Sorgula butonuna bastığımda güncel kurların gelmesi lazım..
Dosya: https://yadi.sk/i/0XuDU42Wc9nuQ indirebilirsiniz.
Mail için cemberkan@gmail.com a gönderebilirseniz sevinirim. Çok teşekkürler şimdiden...
 
Korhan Ayhan' Alıntı:
Ekteki dosyayı inceleyiniz.

KUR ALMA.rar - 37 KB
Genişletmek için tıkla ...

burada bir yanlışlık var. 1 gün önce ki kuru almak yerine son tarihe 15/10/2014 yazıyorsun sistem 14/10/2014 de kadar olan kurları sıralıyor.

daha önceki yapılan program da 15/10/2014 de satırında 14/10/2014 ün kuru yazıyordu.

bu şekilde düzenleme şansımız var mı yeniden.

şirkette çok lazım oluyordu program.
 
cemberkan' Alıntı:
Bıktırdım sizi ama gerçekten çok acil ihtiyacım var. Yardımcı olabilecek kimse var mı?
Dosya: https://yadi.sk/i/0XuDU42Wc9nuQ indirebilirsiniz.
Mail için cemberkan@gmail.com a gönderebilirseniz sevinirim.
Genişletmek için tıkla ...

kod:


Kod: 
#If Win64 Then
Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare PtrSafe Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#Else
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If


Sub SORGULA()

URL = "http://www.tcmb.gov.tr"

If (InternetCheckConnection(URL & "/", &H1, 0&) = 0) Then MsgBox "internet bağlantısı yok": Exit Sub


Application.ScreenUpdating = False



sat = 6
sut = 1
baslangıc = Cells(1, "b")
bitis = Cells(2, "b")

If IsDate(baslangıc) = False Then MsgBox "Başlangıç tarihi yanlış": Exit Sub
If IsDate(bitis) = False Then MsgBox "Bitiş tarihi yanlış": Exit Sub


If CDate(baslangıc) <= CDate(bitis) Then
yer1 = CDate(baslangıc)
yer2 = CDate(bitis)
Else
yer2 = CDate(baslangıc)
yer1 = CDate(bitis)
End If


On Error Resume Next

Sayfa_Adı = ActiveSheet.Name
    



Application.DisplayAlerts = False
Sheets("KURLAR").Delete
Application.DisplayAlerts = True

Sheets.Add
ActiveSheet.Name = "KURLAR"

Sheets(Sayfa_Adı).Select


Rows("6:" & Rows.Count).ClearContents
Rows("6:" & Rows.Count).Interior.ColorIndex = xlNone


For M = 0 To Val(yer2 - yer1)
Tarih = yer1 + M

If CDate(Tarih) > CDate(Format(Now, "dd.mm.yyyy")) Then
GoTo Atla2
End If

If CDate(Tarih) = CDate(Format(Now, "dd.mm.yyyy")) And "15:30:00" >= CDate(Format(Now, "hh:nn")) Then
GoTo Atla1
End If

If "01.01" = Format((Tarih), "dd/mm") Or "23.04" = Format((Tarih), "dd/mm") Or "01.05" = Format((Tarih), "dd/mm") Or "19.05" = Format((Tarih), "dd/mm") _
Or "30.08" = Format((Tarih), "dd/mm") Or "28.10" = Format((Tarih), "dd/mm") Or "29.10" = Format((Tarih), "dd/mm") Then
GoTo Atla1
End If

If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then
GoTo Atla1
End If


deg1 = Format(Val(Mid(Tarih, 1, 2)), "00")
deg2 = Format(Val(Mid(Tarih, 4, 2)), "00")
deg3 = Format(Val(Mid(Tarih, 7, 4)), "00")

URL1 = "http://www.tcmb.gov.tr/kurlar/" & deg3 & deg2 & "/" & deg1 & deg2 & deg3 & ".xml"
Sheets("KURLAR").Cells.ClearContents

With Application
.DecimalSeparator = "."
.ThousandsSeparator = ","
End With
With Sheets("KURLAR").QueryTables.Add(Connection:="URL;" & URL1, Destination:=Sheets("KURLAR").Range("A1"))

.RefreshStyle = xlOverwriteCells
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

With Application
.DecimalSeparator = ","
.ThousandsSeparator = "."
End With


If Val(Sheets("KURLAR").Cells(Rows.Count, "a").End(3).Row) <= 1 Then
Cells(sat, sut) = Tarih
Cells(sat, sut).Interior.ColorIndex = 8
Cells(sat, sut + 1).Value = "Bugün işlem yok"
sat = sat + 1
GoTo Atla1
End If

satır = Sheets("KURLAR").Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sutun = Sheets("KURLAR").Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

simge = 5
ReDim deg(simge)

deg(1) = "USD/TRY"
deg(2) = "EUR/TRY"
deg(3) = "GBP/TRY"
deg(4) = "EUR/USD"
deg(5) = "GBP/USD"

sut2 = 4
sut3 = 2

Cells(sat, sut) = Tarih

For i = 1 To simge
Dim aranan As String
Dim Rng As Range
aranan = deg(i)

With Sheets("KURLAR").Range(Sheets("KURLAR").Cells(1, 1), Sheets("KURLAR").Cells(satır, sutun))
Set Rng = .Find(What:=aranan, LookIn:=xlFormulas, lookat:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not Rng Is Nothing Then
If IsNumeric(Sheets("KURLAR").Cells(Rng.Row, 3)) = True Then sut2 = 3

For j = sut2 To sut2 + 4
If IsNumeric(Sheets("KURLAR").Cells(Rng.Row, j)) = True Then
If Len(Trim(Sheets("KURLAR").Cells(Rng.Row, j))) > 0 Then
Cells(sat, sut3) = Sheets("KURLAR").Cells(Rng.Row, j)
sut3 = sut3 + 1

End If
End If
Next
Else
'MsgBox "Sonuç yok"
End If
End With
Next i

sat = sat + 1

Atla1:

Next M
Atla2:

Application.DisplayAlerts = False
Sheets("KURLAR").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "işlem tamam"

End Sub
 
Size daha önce 16 nolu mesajdaki dosyayı hazırlamıştım. Aynı dosyayı revize ettim. Deneyiniz.

musa yüksel' Alıntı:
burada bir yanlışlık var. 1 gün önce ki kuru almak yerine son tarihe 15/10/2014 yazıyorsun sistem 14/10/2014 de kadar olan kurları sıralıyor.

daha önceki yapılan program da 15/10/2014 de satırında 14/10/2014 ün kuru yazıyordu.

bu şekilde düzenleme şansımız var mı yeniden.

şirkette çok lazım oluyordu program.
Genişletmek için tıkla ...
 

Ekli dosyalar

Korhan Ayhan' Alıntı:
Merhaba,

Dosyanıza gerekli eklemeleri yaptım. İki sayfa ekledim. EUR ve USD kurlarını aldırdım. Size hangisi lazımsa onu kullanabilirsiniz. Kuru aldırmak istediğiniz hücreye DÜŞEYARA formülü ile bilgileri aktarabilirsiniz.
Genişletmek için tıkla ...



ÜSTAT BU TABLOYU ÇALIŞTIRDIĞIMDA BENDE BOŞ GELİYOR 01.02.2016 -03.02.2016 ( ÖRNEK OLARAK ) YAZITORUM ?

tEŞEKKÜRLER.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst