döviz kuru

[sinnernekolens]

Arkadaşlar aşağıdaki url neden hata veriyor yardımcı olmanızı rica ederim

Sub dovizz()
Dim Hucre As Range

With Sheets("Döviz")
.Range("A2:C5").ClearContents
With .QueryTables.Add(Connection:="URL;http://www.tcmb.gov.tr/yeni/tablolar.php", Destination:=.Range("A2"))
.WebFormatting = xlWebFormattingNone
.WebTables = "4"
.Refresh BackgroundQuery:=False
End With

For Each Hucre In .Range("B4:C5")
Hucre = Hucre / 10000
Next

.Range("C2").Value = Now
.Range("C2").NumberFormat = "dd.mm.yyyy hh:mm:ss"
.Range("B4:C5").NumberFormat = "General"
.Range("A:C").EntireColumn.AutoFit
End With

MsgBox "Kur bilgileri güncellenmiştir.", vbInformation
End Sub

 

[sinnernekolens]

Yardımlarınızı bekliyorum

 

[Korhan Ayhan]

TCMB sitesi tablo yapısını değiştirdiği için hata alıyorsunuz.

Alternatif olarak aşağıdaki kodu kullanabilirsiniz.

Boş bir excel dosyasında deneyiniz.

Sub Kurlari_Guncelle()
    Dim Veri As Range
    
    With Application
        .ScreenUpdating = False
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    
    Cells.Delete
    
    ActiveWorkbook.XmlImport URL:="http://www.tcmb.gov.tr/kurlar/today.xml", _
    ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$A$1")
    
    Range("A3:A4").EntireRow.Delete
    Range("A4:A18").EntireRow.Delete
    Range("B:G").EntireColumn.Delete
    Range("C:C").EntireColumn.Delete
    Range("G:H").EntireColumn.Delete
    Range("A1:F1") = Array("TARİH", "DÖVİZ TÜRÜ", "DÖVİZ ALIŞ", "DÖVİZ SATIŞ", "EFEKTİF ALIŞ", "EFEKTİF SATIŞ")
    Range("A:F").EntireColumn.AutoFit

    For Each Veri In Range("C2:F3")
        Veri = CDbl(Replace(Veri.Value, ".", ","))
        Veri.NumberFormat = "_-* #,##0.0000 $_-;-* #,##0.0000 $_-;_-* ""-""?? $_-;_-@_-"
    Next

    Range("A2:A3").NumberFormat = "dd.mm.yyyy"
    Range("A1:F3").Copy
    Range("A5").PasteSpecial xlPasteValuesAndNumberFormats
    Range("A5").PasteSpecial xlPasteFormats
    
    Range("A1:A4").EntireRow.Delete
    Range("A1").Select
    
    With Application
        .ScreenUpdating = True
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = True
    End With

    MsgBox "Kurlar güncellenmiştir.", vbInformation
End Sub

 

[sinnernekolens]

teşekkür ederim sağol

 

[sinnernekolens]

Değerli üstadlar ekli makro ile döviz kuru çekmek istiyorum ama sayfadaki verileri siliyor ve yapıysını değiştiriyor.Güncelleme butonuna bastığımda güncelleme tarih ve saatinide yazabilirmiyiz.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub Kurlari_Guncelle()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Range
    
    With Application
        .ScreenUpdating = False
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    
    Set S1 = Sheets("PDA")
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Kur").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Sheets.Add
    ActiveSheet.Name = "Kur"
    Set S2 = Sheets("Kur")
    
    With S2
        .Cells.Delete
        
        ActiveWorkbook.XmlImport URL:="http://www.tcmb.gov.tr/kurlar/today.xml", _
        ImportMap:=Nothing, Overwrite:=True, Destination:=.Range("$A$1")
        
        .Range("A3:A4").EntireRow.Delete
        .Range("A4:A18").EntireRow.Delete
        .Range("B:G").EntireColumn.Delete
        .Range("C:C").EntireColumn.Delete
        .Range("G:H").EntireColumn.Delete
        .Range("A1:F1") = Array("TARİH", "DÖVİZ TÜRÜ", "DÖVİZ ALIŞ", "DÖVİZ SATIŞ", "EFEKTİF ALIŞ", "EFEKTİF SATIŞ")
        .Range("A:F").EntireColumn.AutoFit
    
        For Each Veri In .Range("C2:F3")
            Veri = CDbl(Replace(Veri.Value, ".", ","))
            Veri.NumberFormat = "_-* #,##0.0000 $_-;-* #,##0.0000 $_-;_-* ""-""?? $_-;_-@_-"
        Next
    
        .Range("A2:A3").NumberFormat = "dd.mm.yyyy"
        .Range("A1:F3").Copy
        .Range("A5").PasteSpecial xlPasteValuesAndNumberFormats
        .Range("A5").PasteSpecial xlPasteFormats
        
        .Range("A1:A4").EntireRow.Delete
    End With
    
    S2.Range("A1:D4").Copy S1.Range("R13")
    S1.Range("R14:R15") = Now
    S1.Range("R14:R15").NumberFormat = "dd mmmm yyyy hh:mm:ss"
    S1.Range("R14:R15").EntireColumn.AutoFit
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Kur").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    With Application
        .ScreenUpdating = True
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = True
    End With

    MsgBox "Kurlar güncellenmiştir.", vbInformation
End Sub

 

[sinnernekolens]

Teşekkür ederim Allah razı olsun şimdi oldu.

 

[tahsinanarat]

Korhan hocam, Kazakistan ve Kırgızistan ülkelerinin de para birimlerinin sorgulamasını yapabilirmiyiz.

 

[Korhan Ayhan]

Bu kur bilgileri hangi sitede yayınlanıyor.

 

[tahsinanarat]

Sn.Korhan Hocam.
http://tr.investing.com/currencies/usd-kzt-converter
https://www.mataf.net/tr/currency/converter-KZT-USD
yukarıdaki linklerde böyle bir çevirici sitesi var.

Bizim amacımız tarihi girdiğimizde girdiğimiz KZT yi USD ye çeviri yapması yeterli olacak, bizde USD miktarını TL. çevireceğiz.