Tcmb alım satıma konu olmayan döviz bilgilerini sorgulama

[eiyalcin]

Ekteki dosyada "http://www.tcmb.gov.tr/yeni/kurlar/kurlar_tr.php?" sayfasından döviz kurlarını sorgulayabiliyorum.

Ancak dosyayı Alım satıma konu olmayan döviz kurları yani "http://www.tcmb.gov.tr/yeni/bilgiamackur/kurlar_tr.php" sayfasından sorgulama yapmak istediğimde , örneğin RUBLE kuru için 01-30 eylül arası sadece 25 eylül ü getirdi.

Bu konuda yardımlarınızı rica ediyorum. İyi Çalışmalar dilerim...

 

[eiyalcin]

bu konuda yardımcı olacak arkadaş yok mu acaba ?

 

[Korhan Ayhan]

Selamlar,

Sitenin bahsettiğiniz bölümden excele veri aktarınca bir kitaba bağlantı oluşmaktadır. Bu bağlantıda kurulamadığı için kur bilgilerinin bulunduğu hücreler #BAŞV! hatası vermektedir. Ekli dosyanın 2. sayfasında bunu görebilirsiniz. Yine dosyanın 1. sayfasında A1 hücresine tarih yazıp butona tıklarsanız RUS RUBLESİ kur bilgisi B1 hücresine gelecektir. Siz diğer kur bilgilerinide aşağıdaki kodda kırmızı renkle belirttiğim değerlerle oynayarak hücrelere alabilirsiniz. Kırmızı renkle belirttiğim satırı aşağıdaki şekilde mesaj kutusuna alarak döndürdüğü değerleri kontrol edebilirsiniz.

MsgBox Mid(.Document.All.Item(0).Innertext, [COLOR=red]1090, 25[/COLOR])

Option Explicit
 
Sub KUR_SORGULA_RUS_RUBLESİ()
    Dim İE As Object, TARİH As Date, URL As String, BUL As String, KUR_RUBLE As Double
 
    Set İE = CreateObject("InternetExplorer.Application")
 
    TARİH = Range("A1")
 
    If Weekday(TARİH, vbMonday) > 5 Then
    TARİH = TARİH - (Weekday(TARİH, vbMonday) - 5)
    If MsgBox("Resmi tatil, hafta sonu ve yarım iş günü çalışılan günlerde gösterge niteliğindeki kur bilgisi yayımlanmamaktadır." _
    & vbCrLf & TARİH & " gününe ait kur bilgisini almak ister misiniz ?", vbCritical + vbYesNo) = vbYes Then
    Else
    Exit Sub
    End If
    End If
 
    URL = "[URL]http://www.tcmb.gov.tr/bilgiamackur/[/URL]" & Year(TARİH) & Format(Month(TARİH), "00") & "/" & Format(Day(TARİH), "00") & Format(Month(TARİH), "00") & Year(TARİH) & ".html"
 
 
    On Error GoTo Son
 
    With Sheets("Sayfa1")
        .Range("B1").Value = 0
 
        With İE
            .Navigate URL
            Application.Wait Now + TimeValue("00:00:01")
            Do While .Busy
            Loop
            BUL = Mid(.Document.All.Item(0).Innertext, [COLOR=red]1090, 25[/COLOR])
            KUR_RUBLE = Replace(Replace(BUL, "RUBRUS RUBLESİ", ""), ".", ",")
            .Quit
        End With
 
        .Range("A1").Value = TARİH
        .Range("B1").Value = CDbl(KUR_RUBLE)
    End With
 
    Set İE = Nothing
    Exit Sub
 
Son:
    Set İE = Nothing
    MsgBox "Kur bilgisine ulaşılamadı !", vbExclamation
End Sub

 

[eiyalcin]

hocam çok işime yaradı , ellerine sağlık

 

[eiyalcin]

hocam günlük olarak değil de , tarih aralığı vererek rus rublesini çekebilirmiyim

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.


Kullanılan kod;

Option Explicit
 
Sub KUR_SORGULA_RUS_RUBLESİ()
    Dim İE As Object, İLK_TARİH As Date, SON_TARİH As Date, TARİH As Date, YENİ_TARİH As Date, SORGULANAN_TARİH As Date
    Dim SATIR As Long, URL As String, BUL As String, KUR_RUBLE As Double
 
    Set İE = CreateObject("InternetExplorer.Application")
 
    İLK_TARİH = Range("B1")
    SON_TARİH = Range("B2")
    Range("A6:C65536").ClearContents
 
    SATIR = 6
 
    For TARİH = İLK_TARİH To SON_TARİH
 
    SORGULANAN_TARİH = TARİH
 
    If Weekday(TARİH, vbMonday) > 5 Then
    YENİ_TARİH = TARİH - (Weekday(TARİH, vbMonday) - 5)
    Else
    YENİ_TARİH = TARİH
    End If
 
    URL = "[URL]http://www.tcmb.gov.tr/bilgiamackur/[/URL]" & Year(YENİ_TARİH) & Format(Month(TARİH), "00") & "/" & Format(Day(TARİH), "00") & Format(Month(YENİ_TARİH), "00") & Year(YENİ_TARİH) & ".html"
 
    On Error Resume Next
 
    With Sheets("Sayfa1")
 
        With İE
            .Navigate URL
            Application.Wait Now + TimeValue("00:00:01")
            Do While .Busy
            Loop
            BUL = Mid(.Document.All.Item(0).Innertext, 1090, 25)
            KUR_RUBLE = Replace(Replace(BUL, "RUBRUS RUBLESİ", ""), ".", ",")
        End With
 
        .Cells(SATIR, "A").Value = SORGULANAN_TARİH
        .Cells(SATIR, "B").Value = YENİ_TARİH
        .Cells(SATIR, "C").Value = CDbl(KUR_RUBLE)
        SATIR = SATIR + 1
 
    End With
 
    Next
 
    Set İE = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[eiyalcin]

ellerinize sağlık tşk ederim