• DİKKAT

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

TCMB veri çekme

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.

C++: 
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
 
Ö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.
 
Görseldeki sonuçlar işinize yarıyorsa ücretli destek için özelden iletişime geçebilirsiniz..

Animation.gif
 

Ekli dosyalar

  • Animation.gif
    Animation.gif
    759.9 KB · Görüntüleme: 7
Ö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.
 
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.

Kod: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst