Çapraz Kur Hk;

[mahmyt]

Arkadaşlar merhaba ekteki dosyaları döviz kuruna göre günlük kur getirebiliyorum; ancak çapraz kur getirme işlemini birr türlü çözemedim.

Konu ile ilgili yardımcı olursanız sevinirim.

 

[Suskun]

Deneyin

DefVar E


Function WebDoviz(ByVal Tarih As Date, ByVal DovTip As String, ByVal Tipi As Long) As Variant
    'TCMB Sitesindengünlük döviz kurları alma.
    'Suskun
    'Tarih  Döviz kuru tarihi
    'Döviz Cinsi  Merkez bankasında kullanılan döviz kodlaması. USD, EUR, GBP vb..
    'Döviz Değerlendirme Tipi
    '        Döviz Alış    : 1
    '        Döviz Satış   : 2
    '        Efektif Alış  : 3
    '        Efektif Satış : 4
    '        USD Çapraz kur: 5
    '        Diğer Çapraz kur: 6 'EUR/USD GBP/USD KWD/USD
    'Kullanım :
    '=WebDoviz(Tarih Parametresi, Döviz Cinsi Parametresi, Döviz Değer Parametresi)
    '=webdoviz("29.09.2014";"usd";1)     29 Eylül 2014 tarihli USD döviz alış kuru
    '
    'Orijinal Kod eXCELvba.nET Tarkan VURAL
    'http://excelvba.net/viewtopic.php?f=38&t=19305&p=145346
    Dim KurGunu As String, path As String, KUR As Double
    Dim icerik As String, xmlhttp As Object, evn As Variant
    Dim Rng As Range
    Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
    '  Application.Volatile
    DovTip = UCase(DovTip)

    If Tarih <= 0 Then Tarih = CDate(Date) 'Tarih boşşa bugünün tarihini al
    If Tarih > CDate(Date) Then 'Tarih bugünden büyükse çık
        WebDoviz = 0
        Exit Function
    End If
    If Weekday(Tarih, vbMonday) > 5 Then
        Tarih = Tarih - (Weekday(Tarih, vbMonday) - 5) 'Tarih cumartesi pazara gelirse  cuma açıklanan değer
    End If
TekrarAra:  'Kur'un açıklanmadığı günlerde (tatil günleri) Kurun açıklandığı son tarihe gider
    KurGunu = Format(Tarih, "yyyymm") & "/" & Format(Tarih, "ddmmyyyy")
    path = "https://www.tcmb.gov.tr/kurlar/" & KurGunu & ".xml"
    
    xmlhttp.Open "GET", path, False
    xmlhttp.Send '"at"
    
    Do Until xmlhttp.readyState = 4
        DoEvents
    Loop

    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>")
                evn1 = Split(sonuclar(1), "<ForexBuying>")
                evn2 = Split(sonuclar(1), "<ForexSelling>")
                evn3 = Split(sonuclar(1), "<BanknoteBuying>")
                evn4 = Split(sonuclar(1), "<BanknoteSelling>")
                evn5 = Split(sonuclar(1), "<CrossRateUSD>")
                evn6 = Split(sonuclar(1), "<CrossRateOther>") 'EUR/USD GBP/USD KWD/USD
                Select Case Tipi
                    Case 1: evn = Split(evn1(1), "</")
                    Case 2: evn = Split(evn2(1), "</")
                    Case 3: evn = Split(evn3(1), "</")
                    Case 4: evn = Split(evn4(1), "</")
                    Case 5: evn = Split(evn5(1), "</")
                    Case 6: evn = Split(evn6(1), "</")
                End Select
                Exit For
            End If
        Next Y
    Else  ' resmi ve bayram tarihlerine denk gelen  #DEĞER! hatasını sıfırlama
            
        Tarih = Tarih - 1   ' En son açıklanan kur arihine kadar eksilt.
        GoTo TekrarAra

    End If
    'Kuruş hanesini virgül kullananlar için
     WebDoviz = Replace(evn(0), ".", ",")
    'Kuruş hanesini nokta kullananlar için
    'WebDoviz = evn(0)
End Function