TCMB veri çekme

[bmutlu966]

TCMB - Saat Başı Belirlenen Döviz Kurları ve Altın Fiyatları linkinden herhangi bir geçmiş tarihteki saat 10:00 da yayınlanan döviz kurlarını çekmek istiyorum. MSXML2.XMLHTTP ile nasıl çekebilirim.

 

[ÖmerFaruk]

Forumda @Haluk beyin güzel bir çalışması.
Saat 10daki değeri veriyor. Ben de buna sadece resmi tatilleri ekledim. Örneğin Cumartesi arıyorsanız Cumayı veriyor direkt.
Ben eklenti olarak excelimde kullanıyorum.
Eğer sırf dövizsatış kullanacanız Değişkeni iptal edip kod içine sabit koyabilirsiniz.

Function TCMB_Kur(Tarih As Date, DovTip As String, Tipi As String) As Variant
    'Haluk
    '16/11/2017
  
    Dim xDoc As Object
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.async = False
    xDoc.validateOnParse = False
    Tarih = Tarih + 1
RESMITATİL:
    Tarih = Tarih - 1
        If Tarih = Date Then
            strURL = "https://www.tcmb.gov.tr/kurlar/today.xml"
        Else
            If Weekday(Tarih, vbMonday) = 6 Then
                Tarih = Tarih - 1
            ElseIf Weekday(Tarih, vbMonday) = 7 Then
                 Tarih = Tarih - 2
             End If
            
             myDay = Format(Day(CDate(Tarih + 0)), "00")
             myMonth = Format(CDate(Month(Tarih + 0)), "00")
             myYear = Year(CDate(Tarih + 0))
            
             strURL = "https://www.tcmb.gov.tr/kurlar/" & myYear & myMonth & "/" & myDay & myMonth & myYear & ".xml"
         End If
        xDoc.Load strURL
        On Error GoTo RESMITATİL
        Set KurListesi = xDoc.DocumentElement
        Select Case DovTip
            Case Is = "USD"
                Select Case Tipi
                    Case Is = "Döviz Alış"
                    RetVal = KurListesi.ChildNodes(0).ChildNodes(3).Text
                    Case Is = "Döviz Satış"
                    RetVal = KurListesi.ChildNodes(0).ChildNodes(4).Text
                    Case Is = "Efektif Alış"
                    RetVal = KurListesi.ChildNodes(0).ChildNodes(5).Text
                    Case Is = "Efektif Satış"
                    RetVal = KurListesi.ChildNodes(0).ChildNodes(6).Text
                End Select
            Case Is = "EUR"
                Select Case Tipi
                    Case Is = "Döviz Alış"
                    RetVal = KurListesi.ChildNodes(3).ChildNodes(3).Text
                    Case Is = "Döviz Satış"
                    RetVal = KurListesi.ChildNodes(3).ChildNodes(4).Text
                    Case Is = "Efektif Alış"
                    RetVal = KurListesi.ChildNodes(3).ChildNodes(5).Text
                    Case Is = "Efektif Satış"
                    RetVal = KurListesi.ChildNodes(3).ChildNodes(6).Text
                End Select
         End Select 
    TCMB_Kur = Replace(RetVal, ".", ",") + 0
End Function

 

[bmutlu966]

Ömer bey ilginiz için çok teşekkürler. Ancak bu kodlar saat 15:30'daki gösterge niteliğindeki kurları veriyor. Bana verdiğim linkteki saat 10:00 Alış kurları lazım.

 

[Korhan Ayhan]

Görseldeki sonuçlar işinize yarıyorsa ücretli destek için özelden iletişime geçebilirsiniz..

 

[ÖmerFaruk]

Örnek olarak
RetVal = KurListesi.ChildNodes(0).ChildNodes(3).Text
Parantez içindeki raklamları değiştirerek farklı saatleri alabilirsiniz sanıyorum. Denemeiz lazım.
Ayrıca ben de saat 10.00 değerleri için kontrol ettiğimde bu haliyle 10.00 daki değerle örtüüşüyordu. Belki de kontrol ettiğim tarihte 10 ile 15 arasında değişiklik yoksa yanlış anlamış olabilirim. Ama yukarıda bahsettiğim değişiklikleri yaparak çözülmesi çok da sorun olmasa gerek.

Eğer olmuyorsa Korhan beyin mesajı size çözüm olacaktır.

 

[Erdem Akdemir]

Merhaba,

Chatgpt'den biraz destek alarak aşağıdaki kodu kullanabilirsiniz.
Ben sadece verinin çekileceği xml URL'sini sayfa kaynağından tespit etim. Gerisini chatgpt yazdı, kur değerlerini 1 ile çarpma kısmını ekledim.

Sub ImportTCMBDovizKuru()

    Dim xmlHttp As Object
    Dim xmlDoc As Object
    Dim kurNode As Object
    Dim ws As Worksheet
    Dim rowNum As Long
    Dim sURL As String
    Dim nodeValue As Object


    Set ws = ThisWorkbook.Sheets("Sayfa1")

    ' XML verilerini almak için nesneleri oluştur
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False ' Senkron yükleme


    sURL = "https://www.tcmb.gov.tr/reeskontkur/202507/18072025-1000.xml"
    ' Eğer XML verisini manuel olarak bir dosyaya kaydettiyseniz, dosya yolu kullanabilirsiniz:

    On Error GoTo ErrorHandler

    ' URL'den XML verilerini al
    xmlHttp.Open "GET", sURL, False
    xmlHttp.send

    ' Durum kodunu kontrol et
    If xmlHttp.Status = 200 Then
        ' XML içeriğini yükle
        If Not xmlDoc.LoadXML(xmlHttp.responseText) Then
            MsgBox "XML verisi yüklenemedi veya bozuk. Hata: " & xmlDoc.parseError.reason, vbCritical
            Exit Sub
        End If
        
        Cells.Clear
        
        ws.Cells(1, 1).Value = "Doviz Cinsi Tabani"
        ws.Cells(1, 2).Value = "Doviz Cinsi"
        ws.Cells(1, 3).Value = "Birim"
        ws.Cells(1, 4).Value = "Alis"

        rowNum = 2

        Dim dataNodes As Object
        Set dataNodes = xmlDoc.SelectNodes("/tcmbVeri/doviz_kur_liste/kur")

        If dataNodes Is Nothing Or dataNodes.Length = 0 Then
            MsgBox "Belirtilen XPath ile 'kur' düğümleri bulunamadı. Lütfen XML yapısını ve XPath'i kontrol edin.", vbExclamation
            Exit Sub
        End If

        For Each kurNode In dataNodes
            Set nodeValue = kurNode.SelectSingleNode("doviz_cinsi_tabani")
            If Not nodeValue Is Nothing Then ws.Cells(rowNum, 1).Value = nodeValue.Text Else ws.Cells(rowNum, 1).Value = ""

            Set nodeValue = kurNode.SelectSingleNode("doviz_cinsi")
            If Not nodeValue Is Nothing Then ws.Cells(rowNum, 2).Value = nodeValue.Text Else ws.Cells(rowNum, 2).Value = ""

            Set nodeValue = kurNode.SelectSingleNode("birim")
            If Not nodeValue Is Nothing Then ws.Cells(rowNum, 3).Value = nodeValue.Text Else ws.Cells(rowNum, 3).Value = ""

            Set nodeValue = kurNode.SelectSingleNode("alis")
            If Not nodeValue Is Nothing Then ws.Cells(rowNum, 4).Value = nodeValue.Text * 1 Else ws.Cells(rowNum, 4).Value = ""

            rowNum = rowNum + 1
        Next kurNode

        MsgBox "Döviz kuru verileri başarıyla aktarıldı! Toplam " & (rowNum - 2) & " kayıt eklendi.", vbInformation
    Else
        MsgBox "XML verisi alınamadı. HTTP Durum Kodu: " & xmlHttp.Status & " - " & xmlHttp.statusText, vbCritical
    End If

    Exit Sub

ErrorHandler:
    MsgBox "VBA kodunda bir hata oluştu: " & Err.Description, vbCritical

End Sub