TCMB Döviz kurları

[adigeturklim]

Merhaba Excel dostları,

Forumda TCMB döviz kurları alımı ile ilgili dehşet çalışmalar var fakat daha hızlı bir çalışma için ekli dosyaki gibi hergün sadece içinde bulunduğumuz güne ait kurları çekip ilgili hücreye yazabilecek şekilde bir format düzenleyebilir miyiz. Yardımlarınız için teşekkür ederim.

 

[askm]

Aşağıdaki şekilde deneyin.
Yalnız H (PARİTE (USD/HYRVNIA)) sütununu bilemedim.

Sub ASKM_Kur_Cek()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim SonSat As Long
SonSat = s1.Range("B" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False
    Dim alan As Range
    s2.Cells.Clear
    With s2.QueryTables.Add(Connection:= _
        "URL;http://www.tcmb.gov.tr/kurlar/today.xml", Destination:=s2.Range("$A$1"))
        .Name = "today_1"
        .Refresh BackgroundQuery:=False
    End With
    Dim usd#
    usd = s2.Range("D3").Value
    For trh = 3 To SonSat
        If CDate(s1.Cells(trh, "B")) = CDate(Date) Then
            s1.Range("C" & trh & ":H" & trh).ClearContents
            s1.Cells(trh, "C") = usd / 10000
            s1.Cells(trh, "D") = s2.Range("D6") / 10000   'EURO
            s1.Cells(trh, "E") = s2.Range("D33") / 10000  'PARITE (EURO/USD)
            s1.Cells(trh, "F") = s2.Range("D34") / 10000  'PARITE (GBP/USD)
            s1.Cells(trh, "G") = s2.Range("D38") / 10000  'PARITE (USD/RUBLE)
            s1.Cells(trh, "H") = s2.Range("D34") / 10000  'PARİTE (USD/HYRVNIA)
            s2.Cells.Clear
            GoTo Son
        End If
    Next
Son:
MsgBox "Güncelleme tamamlanmıştır...", vbInformation, "ASKM"
End Sub

 

[adigeturklim]

Sayın askm, yardımlarınız için teşekkür ederim. İki düzeltme yapmak istesek nasıl yapabiliriz acaba yardımcı olabilirseniz sevinirim;

1- PARİTE (USD/HYRVNIA) olan kısmı kodlardan çıkarmak gerekiyor sanırım.
2- PARITE (USD/RUBLE) yazarken 1 Ruble = 0,5693 değilde, 1 Usd =56,93 olarak yazması gerekir

bu iki konuyu basitse çözebilir miyiz rica etsem

 

[askm]

Sub ASKM_Kur_Cek()
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim SonSat As Long
SonSat = s1.Range("B" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False
    Dim alan As Range
    s2.Cells.Clear
    With s2.QueryTables.Add(Connection:= _
        "URL;http://www.tcmb.gov.tr/kurlar/today.xml", Destination:=s2.Range("$A$1"))
        .Name = "today_1"
        .Refresh BackgroundQuery:=False
    End With
    Dim usd#
    usd = s2.Range("D3").Value
    For trh = 3 To SonSat
        If CDate(s1.Cells(trh, "B")) = CDate(Date) Then
            s1.Range("C" & trh & ":H" & trh).ClearContents
            s1.Cells(trh, "C") = usd / 10000
            s1.Cells(trh, "D") = s2.Range("D6") / 10000   'EURO
            s1.Cells(trh, "E") = s2.Range("D33") / 10000  'PARITE (EURO/USD)
            s1.Cells(trh, "F") = s2.Range("D34") / 10000  'PARITE (GBP/USD)
            s1.Cells(trh, "G") = s2.Range("D38") / 100  'PARITE (USD/RUBLE)
            's1.Cells(trh, "H") = s2.Range("D34") / 10000  'PARİTE (USD/HYRVNIA)
            s2.Cells.Clear
            GoTo Son
        End If
    Next
Son:
MsgBox "Güncelleme tamamlanmıştır...", vbInformation, "ASKM"
End Sub

 

[adigeturklim]

Sayın askm harika olmuş, örnek dosya içinde gayet güzel çalışıyor yalnız kodları orjinal dosyama aldığımda sanırım içinde bulunan mevcut kodlardan dolayı hata veriyor,
mevcut kodlar;

Sub sutunGizle()
Application.ScreenUpdating = False
For i = 4 To 210
If Cells(5, i).Value = [B3].Value Then
Columns(i).Hidden = False
Else
Columns(i).Hidden = True
End If
Next i
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B3]) Is Nothing Then Exit Sub
Call sutunGizle
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub

 

[askm]

Orjinal dosyanızı askmadige34@hotmail.com mail attın bakayım.