Döviz kuru çekme revize

[elevisse]

Değerli Üstadlarım,
TCMB nin sayfası güncellendiğinden eski kur alma makroları maalesef çalışmıyor. Aşağıdaki kodu yeni yapıya göre nasıl uyarlayabilirim? Yardımızı rica ederim. Teşekkürler.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    Dim GÜN As Byte, AY As Byte, YIL As Integer
    Dim TARİH As Date
    Dim KONTROL As Byte
    Dim URL1 As String
    Dim USD As Long
    Dim EUR As Long
    Dim DKK As Long
    Dim GBP As Long
    Set S1 = Sheets("FI Doc")
    Set S2 = Sheets("Fx Rates")
    
    If Intersect(Target, [Q25,R25]) Is Nothing Then Exit Sub
   
    If Target.Count > 1 Then GoTo Çıkış
    If Target = "TRY" Then
    Cells(Target.Row, "S") = 1
    GoTo Çıkış
    End If
    If Target = Empty Then
    Cells(Target.Row, "S") = Empty
    Cells(Target.Row, "T") = Empty
    GoTo Çıkış
    End If
    
    With Application
    .DecimalSeparator = "."
    .ThousandsSeparator = ","
    .UseSystemSeparators = False
    End With
    
    GÜN = Format(Day(Cells(Target.Row, "q")), "00")
    AY = Format(Month(Cells(Target.Row, "q")), "00")
    YIL = Format(Year(Cells(Target.Row, "q")), "0000")
    TARİH = DateSerial(YIL, AY, GÜN)
    
    If TARİH > Date Then
    MsgBox "Bugünden sonraki bir tarihi sorgulayamazsınız !" _
    & Chr(10) & Chr(10) & "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "DİKKAT !"
    GoTo Çıkış
    End If
        
    If (Weekday(TARİH, vbMonday) = 6 Or Weekday(TARİH, vbMonday) = 7) Then
    MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
    & Chr(10) & Chr(10) & "Önceki iş gününe ait kur bilgileri alınacaktır.", vbExclamation, "DİKKAT !"
    End If
    
    KONTROL = Weekday(TARİH, vbMonday)
    If KONTROL > 5 Then
    TARİH = TARİH - (KONTROL - 5)
    Else
    TARİH = TARİH - 1
    End If
    
    Cells(Target.Row, "T") = TARİH
    
    If (Weekday(TARİH, vbMonday) = 6 Or Weekday(TARİH, vbMonday) = 7) Then
    MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
    & Chr(10) & Chr(10) & "Önceki iş gününe ait kur bilgileri alınacaktır.", vbExclamation, "DİKKAT !"
    KONTROL = Weekday(TARİH, vbMonday)
    If KONTROL > 5 Then
    TARİH = TARİH - (KONTROL - 5)
    Else
    TARİH = TARİH - 1
    End If
    Cells(Target.Row, "T") = TARİH
    End If
    
    On Error GoTo Son
    
    URL1 = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(TARİH) & Format(Month(TARİH), "00") & "/" & Format(Day(TARİH), "00") & Format(Month(TARİH), "00") & Year(TARİH) & ".html"
    
    With S2.QueryTables.Add(Connection:=URL1, Destination:=S2.Range("A1"))
        .Name = TARİH
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    
    USD = S2.[B:B].Find("1 ABD DOLARI").Row
    EUR = S2.[B:B].Find("1 EURO").Row
    DKK = S2.[B:B].Find("1 DANİMARKA KRONU").Row
    GBP = S2.[B:B].Find("1 İNGİLİZ STERLİNİ").Row
    
    Select Case Cells(Target.Row, "R")
    Case Is = "DKK"
    Cells(Target.Row, "S") = S2.Cells(DKK, "C")
    Case Is = "EUR"
    Cells(Target.Row, "S") = S2.Cells(EUR, "C")
    Case Is = "GBP"
    Cells(Target.Row, "S") = S2.Cells(GBP, "C")
    Case Is = "USD"
    Cells(Target.Row, "S") = S2.Cells(USD, "C")
    End Select
    
    With Application
    .UseSystemSeparators = True
    End With
    Beep
    Set S1 = Nothing
    Set S2 = Nothing
 
    Exit Sub
Son:

MsgBox "İnternet bağlantısı şu anda kurulamıyor !" & vbCrLf & "Lütfen daha sonra tekrar deneyin.", vbCritical, "UYARI !"
Exit Sub
Çıkış:

End Sub

 

[Zeki Gürsoy]

Web sayfası zamanla değişebilir. XML lokasyonu değişmemiş; hem de çok hızlı kur alabilirsiniz.

Aşağıdaki dosyayı inceleyin.

http://www.excel.web.tr/showpost.php?p=782061&postcount=25

.

 

[Murat OSMA]

Zeki Bey, örnek paylaşım için teşekkürler.

Ellerinize, zihninize sağlık. k::

 

[Korhan Ayhan]

Merhaba,

Dosyanızı eklerseniz gerekli düzeltmeyi yapabilirim.