• Foruma hoş geldin 👋 Ziyaretçi

    Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı ya da giriş yapmalısınız. Foruma üye olmak tamamen ücretsizdir.

    Giriş yap veya Şimdi kayıt ol

Çözüldü TCMB Güncel Kur Hafta Sonu

Bu konu çözüldü olarak işaretlenmiştir. Çözülmediğini düşünüyorsanız konuyu rapor edebilirsiniz.
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
U

ustnromr

Yeni Üye
Katılım
16 Ara 2022
Mesajlar
21
Aldığı beğeni
5
Excel V
Office 2013 TR
Daha önceki konuları araştırdığımda ekteki excel örneğini buldum. Bu excelde tarihlere göre kur çekmede bir problem yok fakat hafta sonuna geldiğinde bir değer alınamıyor. Buradaki sorum şu olacak. Hafta sonuna denk gelen tarihler için o haftanın en son gününe ait kapanış kur bilgisini yazdırabilir miyiz. Yardımlarınızı rica ederim.
 

Ekli dosyalar

Çözüm
M
Merhabalar

Kod: 
Sub getDovizKurlari()
    Dim IE As SHDocVw.InternetExplorer
    Dim HTMLDoc As New MSHTML.HTMLDocument
    Dim HTMLDivs As MSHTML.IHTMLElement
    Dim HTMLDiv As MSHTML.IHTMLElement
    Dim HTMLTables As MSHTML.IHTMLElement
    Dim HTMLTable As MSHTML.IHTMLElement
    Dim HTMLRow As MSHTML.IHTMLElement
    Dim HTMLCol As MSHTML.IHTMLElement
    Dim RowNum As Long, ColNum As Integer
    Dim URL As String
    Dim sayac As Integer
    Dim HaftanınGunu As Byte
    Dim tarih As Date
    Dim Yil As Long, Ay As String, Gun As String
    
    Application.ScreenUpdating = False
    
    HaftanınGunu = Application.Weekday(Date, 2)
    If HaftanınGunu = 6 Then
        tarih = Date - 1
    ElseIf HaftanınGunu = 7 Then
        tarih...
Tarihe göre sırala Oylara göre sırala
Yanıt için teşekkürler, çok güzel bir dosya fakat bu şekilde bir dosyadan ziyade benim basit bir işleme ihtiyacım var. Bugünün tarihine bağlı olarak ne zaman açsam anlık kur bilgisini verecek biçimde. Ekte bir dosya daha paylaşıyorum tam olarak nasıl bir talep olduğunu daha iyi açıklayabilmek adına. Ekteki dosyada güncel kur bilgisini Bugün() olarak ya da hafta sonuna denk geliyor ise bir önceki mevcut kur ne ise o olarak paylaşması gerekiyor. Bir tarih sütunu eklemeden formülü Bugün() denklemi kullanarak yazmam gerek.
 

Ekli dosyalar

Olumlu oy 0 Negatif oyla
aşağıdakine benzer bir fonksiyonla hafta sonlarını cuma yapabilirsiniz
Kod: 
Function xTrhF(xTrh As Date) As Date
    k = xTrh Mod 7
    If k > 1 Then k = 0 Else k = k + 1
    xTrhF = xTrh - k
End Function
 
Olumlu oy 0 Negatif oyla
Malesef bu şekilde bir çözüme gidemedim. Bir önceki yanıtımda tam olarak ne istediğimi doğru açıkladım diye düşünüyorum. İlk paylaşımdaki dosya mükemmel şekilde çalışıyor. Sadece bir tarih girmek yerine işin formül kısmında Bugün() olarak değeri tarih okuyacak ve o güne göre kur bilgisi verecek. Sorun olan günler haftasonu merkez bankasının sitesinden veriyi çekememiş olması oluyor. Aşağıdaki koda bir ekleme yaparak hafta sonlarına denk gelen günüde bir önceki Cuma gününün verisini çekmesi gerekiyor. Mesela (Eğer Bugün()= Cumartesi ise; okuyacağı tarih = Bugün()-1, Eğer Bugün()=Pazar ise; okuyacağı tarih= Bugün()-2, diğer günlerde okuyacağı tarih= Bugün())
Kod: 
DefVar E
Function tcmb(ByVal Tarih As Date, ByVal Dovtip As String, ByVal Tipi As Long) As Variant
Dim gun As String, ay As String, yil As String, path As String, kur As Double
Dim icerik As String, xmlhttp As Object, sorgu As Variant
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
Application.Volatile
Dovtip = UCase(Dovtip)
gun = Day(Tarih): ay = Month(Tarih): yil = Year(Tarih)
If Len(gun) = 1 Then gun = "0" & gun
If Len(ay) = 1 Then ay = "0" & ay
path = "https://www.tcmb.gov.tr/kurlar/" & yil & ay & "/" & gun & ay & yil & ".xml"
xmlhttp.Open "GET", path, False
xmlhttp.send "at"
If xmlhttp.Status = 200 Then
    icerik = xmlhttp.responseText
    temizlik = Split(icerik, "<Currency CrossOrder=")
    For y = 0 To UBound(temizlik)
        If temizlik(y) Like "*=""" & Dovtip & "*" Then
            sonuclar = Split(temizlik(y), "</CurrencyName>")
            sorgu1 = Split(sonuclar(1), "<ForexBuying>")
            sorgu2 = Split(sonuclar(1), "<ForexSelling>")
            sorgu3 = Split(sonuclar(1), "<BanknoteBuying>")
            sorgu4 = Split(sonuclar(1), "<BanknoteSelling>")
            Select Case Tipi
                Case 1: sorgu = Split(sorgu1(1), "</")
                Case 2: sorgu = Split(sorgu2(1), "</")
                Case 3: sorgu = Split(sorgu3(1), "</")
                Case 4: sorgu = Split(sorgu4(1), "</")
            End Select
            Exit For
        End If
    Next y
End If
tcmb = Replace(sorgu(0), ".", ",")
End Function
 
Olumlu oy 0 Negatif oyla
Merhabalar

Kod: 
Sub getDovizKurlari()
    Dim IE As SHDocVw.InternetExplorer
    Dim HTMLDoc As New MSHTML.HTMLDocument
    Dim HTMLDivs As MSHTML.IHTMLElement
    Dim HTMLDiv As MSHTML.IHTMLElement
    Dim HTMLTables As MSHTML.IHTMLElement
    Dim HTMLTable As MSHTML.IHTMLElement
    Dim HTMLRow As MSHTML.IHTMLElement
    Dim HTMLCol As MSHTML.IHTMLElement
    Dim RowNum As Long, ColNum As Integer
    Dim URL As String
    Dim sayac As Integer
    Dim HaftanınGunu As Byte
    Dim tarih As Date
    Dim Yil As Long, Ay As String, Gun As String
    
    Application.ScreenUpdating = False
    
    HaftanınGunu = Application.Weekday(Date, 2)
    If HaftanınGunu = 6 Then
        tarih = Date - 1
    ElseIf HaftanınGunu = 7 Then
        tarih = Date - 2
    Else
        tarih = Date
    End If
    
    tarih = InputBox("Bir tarih giriniz", , tarih)
    
    URL = "https://www.tcmb.gov.tr/kurlar/kurlar_tr.html"
        
    
    Set IE = New SHDocVw.InternetExplorer
    
    IE.Visible = True
    IE.Navigate URL
    
    Do While IE.ReadyState <> READYSTATE_COMPLETE Or IE.Busy
    Loop
    
    Set HTMLDoc = IE.Document
    
    Yil = Year(tarih)
    Set HTMLDivs = HTMLDoc.getElementById("calendar_report")
    For Each HTMLDiv In HTMLDivs.getElementsByTagName("a")
        If HTMLDiv.innerText = Yil Then
            HTMLDiv.Click
            Exit For
        End If
    Next HTMLDiv
    
    Ay = Format(Month(tarih), "00")
    Set HTMLDivs = HTMLDoc.getElementById("calendar_report")
    For Each HTMLDiv In HTMLDivs.getElementsByTagName("div")
        If HTMLDiv.innerText = Ay Then
            HTMLDiv.Click
            Exit For
        End If
    Next HTMLDiv
    
    Gun = Day(tarih)
    Set HTMLDivs = HTMLDoc.getElementById("calendar_report")
    For Each HTMLDiv In HTMLDivs.getElementsByTagName("a")
        If HTMLDiv.innerText = Gun Then
            HTMLDiv.Click
            Exit For
        End If
    Next HTMLDiv
    
    
    Set HTMLDivs = HTMLDoc.getElementById("calendar_report")
    For Each HTMLDiv In HTMLDivs.getElementsByTagName("input")
        If HTMLDiv.ClassName = "form-button w-button email-form-2-submit" Then
            HTMLDiv.Click
            Exit For
        End If
    Next HTMLDiv
    

    ActiveSheet.UsedRange.ClearContents
  
    Application.Wait Now + TimeValue("00:00:07")
    
    
    Set HTMLDivs = HTMLDoc.getElementById("data")
    sayac = 1
    For Each HTMLTables In HTMLDivs.getElementsByTagName("table")
        If sayac = 1 Then
            RowNum = 2
            For Each HTMLRow In HTMLTables.getElementsByTagName("tr")
                ColNum = 1
                For Each HTMLCol In HTMLRow.Children
                    Cells(RowNum, ColNum).Value = HTMLCol.innerText
                    ColNum = ColNum + 1
                Next HTMLCol
                RowNum = RowNum + 1
             Next HTMLRow
        Else
            Exit For
        End If
        sayac = sayac + 1
    Next HTMLTables
    
   IE.Quit
    ActiveSheet.UsedRange.EntireColumn.AutoFit
    Application.ScreenUpdating = True
  
End Sub
 
Olumlu oy 1 Negatif oyla
Çözüm
Aşağıdaki şekilde sorunu çözdüm, umarım faydalı olur.

Kod: 
Function TCMB_Kur(Tarih As Date, DovTip As String, Tipi As String) As Variant

'ÖMER 28.12.2022

  
    Dim xDoc As Object
  
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.async = False
    xDoc.validateOnParse = False
  
    If Tarih = Date Then
        strURL = "http://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 = "http://www.tcmb.gov.tr/kurlar/" & myYear & myMonth & "/" & myDay & myMonth & myYear & ".xml"
    End If
  
    xDoc.Load strURL
  
    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
        Case Is = "GBP"
            Select Case Tipi
                Case Is = "Döviz Alış"
                RetVal = KurListesi.ChildNodes(4).ChildNodes(3).Text
                Case Is = "Döviz Satış"
                RetVal = KurListesi.ChildNodes(4).ChildNodes(4).Text
                Case Is = "Efektif Alış"
                RetVal = KurListesi.ChildNodes(4).ChildNodes(5).Text
                Case Is = "Efektif Satış"
                RetVal = KurListesi.ChildNodes(4).ChildNodes(6).Text
            End Select
    End Select
  
    TCMB_Kur = Replace(RetVal, ".", ",") + 0
End Function

Ayrıca aşağıdaki formül ile de google sheetsden veri alınabilir

Kod: 
=IMPORTXML("https://www.tcmb.gov.tr/kurlar/today.xml";"//Currency";"en-US")

Kod: 
=IMPORTXML("https://www.tcmb.gov.tr/kurlar/today.xml";"//Currency")
 
Olumlu oy 0 Negatif oyla
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Geri
Üst