T.C.M.B döviz kurlarının otomatik excele aktarımı.

fahrenayt · 19 Ağustos 2010

İyi günler forumda arama bölümünden Döviz olarak arattığımda çıkan 13 sayfanın tamamını inceledim ama benim istediğim gibi bir sonuca ulaşamadım aslında sorunum basit ama kod bilgisi olmayınca zorlanıyorum yapmak istediğim şey T.C.M.B. sitesinden günlük döviz kurlarını excel dosyasını açtığımda otomatik önüme gelmesi konuların çoğunda dolar ve Euro için yapılmış ama bana tamamı lazım ve nokta ayıraçları virgül olması lazım. Bana bu konuda yardımcı olabilecek herkese şimdiden teşekkür ediyorum.

Bana lazım olan bilgilerin bulunduğu yerleri ekteki jpeg dosyasında işaretledim.

Evolver · 19 Ağustos 2010

aşağıdaki kodları deneyin

Sub kurlar()
Dim t As Date
Dim url1 As String
t = Date - 1
url1 = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(t) & Format(Month(t), "00") & "/" & Format(Day(t), "00") & Format(Month(t), "00") & Year(t) & ".html"
With QueryTables.Add(Connection:=url1, Destination:=Range("A1"))
.Name = t
.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
End Sub

fahrenayt · 19 Ağustos 2010

Evolver teşekkür ederim yardım için peki bu döviz kurlarındaki ayıraçları nasıl virgül yapabilirim ?

Merhum İdris SERDAR · 19 Ağustos 2010

fahrenayt' Alıntı:
Evolver teşekkür ederim yardım için peki bu döviz kurlarındaki ayıraçları nasıl virgül yapabilirim ?

.

Bu kodlar çalıştı mı?

Bende çalışmadı da...

Çalıştıysa bir örnek dosyaya uygular mısınız?

Veya varsa çalıştıran bir örnek dosyaya uygulayabilir mi?

Şimdi, nerede hata veriyor diye soracaksınız?

Kod:

Sub kurlar()
Dim t As Date
Dim url1 As String
t = Date - 1
url1 = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(t) & Format(Month(t), "00") & "/" & Format(Day(t), "00") & Format(Month(t), "00") & Year(t) & ".html"
[COLOR="Red"][B]With QueryTables.Add(Connection:=url1, Destination:=Range("A1"))[/B][/COLOR]
.Name = t
.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
End Sub

.

Korhan Ayhan · 20 Ağustos 2010

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz.

A2 hücresine tarih girip enter tuşuna bastığınızda döviz kurları otomatik olarak alınacaktır.

TCMB sayfasında bazı tarihlerde yapılan değişikliklerden dolayı sayfa yapısı bozuktur. Bu sebeple 01-05-2009 tarihinden önceki sorguların sayfa yapısı bozuk çıkacaktır. Bu tarihten sonraki tarihleri TCMB internet sayfasında bir değişiklik yapmadığı sürece rahatlıkla kullanabilirsiniz.

Kullanılan kodlar;

Modül1;

Kod:

Option Explicit
 
Sub SORGULA()
    'Korhan AYHAN - 2010 - [URL="http://www.excel.web.tr"]www.excel.web.tr[/URL]
    
    Dim SR As Worksheet, URL1 As String
    Dim X As Date, Y As Date, Kontrol As Byte
    
    Application.ScreenUpdating = False
    
    Set SR = Sheets("RAPOR")
    SR.Select
    
    Range("C1:G2").ClearContents
    Range("A6:IV65536").Clear
    
    If Range("A2") = "" Then
        MsgBox "Lütfen A2 hücresine sorgulamak istediğiniz tarihi giriniz !", vbExclamation, "Dikkat !"
        Range("A2").Select
        Exit Sub
    End If
    
    If InStr(1, Range("A2"), ",") > 0 Or WorksheetFunction.IsText(Range("A2")) Then
        MsgBox Range("A2") & "   Hatalı tarih girişi !" _
        & Chr(10) & Chr(10) & "Lütfen girdiğiniz tarih bilgilerini kontrol ediniz !", vbCritical, "Dikkat !"
        Range("A2").ClearContents
        Range("A2").Select
        Exit Sub
    End If
    
    If Range("A2") > Date Then
        MsgBox "Bugünden sonraki bir günü sorgulayamazsınız !" _
        & Chr(10) & Chr(10) & "Lütfen girdiğiniz tarih bilgilerini kontrol ediniz !", vbCritical, "Dikkat !"
        Range("A2").ClearContents
        Range("A2").Select
        Exit Sub
    End If
    
    If (CheckInternetConnection = False) Then
        MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
        & Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
    Else
    
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    
    For X = SR.Range("A2") To SR.Range("A2") - 7 Step -1
        
        Kontrol = Weekday(X, vbMonday)
        If Kontrol > 5 Then
            Y = X - (Kontrol - 5)
        Else
            Y = X
        End If
        
        On Error Resume Next
        
        URL1 = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(Y) & Format(Month(Y), "00") & "/" & Format(Day(Y), "00") & Format(Month(Y), "00") & Year(Y) & ".html"
        
        With SR.QueryTables.Add(Connection:=URL1, Destination:=SR.Range("A6"))
            .Name = Y
            .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
        
        If SR.Range("A6") <> "" Then GoTo Devam
    Next
Devam:
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    If Y >= DateSerial(2009, 1, 1) And Y <= DateSerial(2010, 4, 8) Then
        Rows(6).Delete
        Range("B6").ClearContents
        Range("C6").Value = "BÜ" & Range("C6").Value
        Rows("9:10").Delete
        Range("D7:G8").HorizontalAlignment = xlCenter
        Range("B20").Value = 100
        Range("C20").Value = "JAPON YENİ"
        Range("B21").ClearContents
        Range("C21").Value = "ÇAPRAZ KURLAR"
        Range("F22").ClearContents
        Range("E22").Value = "AVUSTRALYA DOLARI"
        Range("F29").ClearContents
        Range("E29").Value = "SUUDİ ARABİSTAN RİYALİ"
        Range("B34").ClearContents
        Range("C34").Value = "B" & Range("C34").Value
        Range("A6:A" & Range("A65536").End(3).Row).HorizontalAlignment = xlRight
        Range("C1").Value = Format(Y, "dd mmmm yyyy") & _
        " GÜNÜ SAAT 15:30'DA BELİRLENEN GÖSTERGE NİTELİĞİNDEKİ" & Chr(10) & _
        "TÜRKİYE CUMHURİYET MERKEZ BANKASI KURLARI"
        Range("E22:G32").Merge True
        Range("C6:G8,C21,C34").Font.Bold = True
        Range("C6:G8,C21,C34").Font.ColorIndex = 3
    End If
    
    If Y >= DateSerial(2010, 4, 9) Then
        Rows(6).Delete
        Rows("9:10").Delete
        Range("C7:F8").HorizontalAlignment = xlCenter
        Range("B25").Value = "ÇAPRAZ KURLAR"
        Range("E26").ClearContents
        Range("D26").Value = "AVUSTRALYA DOLARI"
        Range("E33").ClearContents
        Range("D33").Value = "SUUDİ ARABİSTAN RİYALİ"
        Range("A6:A" & Range("A65536").End(3).Row).HorizontalAlignment = xlRight
        Range("C1").Value = Format(Y, "dd mmmm yyyy") & _
        " GÜNÜ SAAT 15:30'DA BELİRLENEN GÖSTERGE NİTELİĞİNDEKİ" & Chr(10) & _
        "TÜRKİYE CUMHURİYET MERKEZ BANKASI KURLARI"
        Range("D26:F40").Merge True
        Range("B6:F8,B25,B42").Font.Bold = True
        Range("B6:F8,B25,B42").Font.ColorIndex = 3
    End If
    
    Cells.EntireColumn.AutoFit
    
    Range("A2").Select
    Application.ScreenUpdating = True
    MsgBox "Döviz sorgulama işlemi başarıyla tamamlanmıştır.", vbInformation
    End If
End Sub
 
Sub TCMB()
    If (CheckInternetConnection = False) Then
    MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
    & Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
    Else
    Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & "[URL]http://www.tcmb.gov.tr[/URL]", vbMaximizedFocus
    End If
End Sub

Modüle2;

Kod:

Option Explicit
 
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" _
(ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, _
ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long
 
Public Function CheckInternetConnection() As Boolean
    Dim Aux As String * 255
    Dim Kontrol As Long
    Kontrol = InternetGetConnectedStateEx(Kontrol, Aux, 254, 0)
    If Kontrol = 1 Then
        CheckInternetConnection = True
    Else
        CheckInternetConnection = False
    End If
End Function

RAPOR isimli sayfanın kod bölümüne;

Kod:

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2")) Is Nothing Then Exit Sub
    SORGULA
End Sub

fahrenayt · 20 Ağustos 2010

Eline emeğine sağlık Korhan bey fazla oluyorum biliyorum ama bunu tarih girmeden otomatik dosyayı açtığımızda güncel olarak önümüze gelmesi mümkünmü ?

Korhan Ayhan · 20 Ağustos 2010

Selamlar,

Ekteki örnek dosya açılırken hep bugünün tarihini otomatik olarak sorgular.

Siz yine başka bir tarihi sorgulamak isterseniz A2 hücresine tarih girip işlem yapabilirsiniz.

fahrenayt · 20 Ağustos 2010

Çok teşekkür ederim ilginiz için çalıştığım yerde her gece bunları elle excele girmek zorunda kalıyordum beni bu dertten kurtardınız allah razı olsun.

turgaycakar · 8 Mayıs 2012

Korhan Bey ,
Gunluk doviz kuru veren dosyada Run Time Error 16 veriyor.
Içinden cıkamadım , yardımınızı rica ederim.

samedyücel · 4 Ağustos 2014

Merhaba, 2007 de çalıştıramadım. Yardımcı olabilirmisiniz.

Korhan Ayhan · 4 Ağustos 2014

Ne gibi bir sorun oluştu?

Tevfik_Kursun · 4 Ağustos 2014

Merhaba Arkadaşlar,
Ben de çalıştıramadım. Her iki dosyada da aynı satırda hata veriyor. İlgilenir misiniz acaba?

Kod:

    For X = SR.Range("A2") To SR.Range("A2") - 7 Step -1

Hata mesajı da "too complex"
İyi çalışmalar
Saygılarımla

Korhan Ayhan · 4 Ağustos 2014

Merhaba,

Değişken tanımlaması sorun oluşturuyor.

Bu satırı;

Kod:

Dim X As Date, Y  As Date, Kontrol As Byte

Bu satırla değiştirip deneyiniz.

Kod:

Dim X As Variant, Y  As Variant, Kontrol As Byte

Not: Örnek dosyadaki kodu hazırladığım sene kur sayfa yapısı farklı olduğu için yeni tarih sorgulandığında kaymalar oluyor. Bunu revize etmek gerekiyor. Bilginiz olsun.

Tevfik_Kursun · 5 Ağustos 2014

Sayın Korhan Hocam,
Çok teşekkür ederim. Yapılan değişiklikten sonra çalıştı. Dediğiniz gibi sayfa yapısı ile ilgili bir sıkıntı var. Ekli dosya 3 defa gelen hata mesajını gösteriyor. Tamam deyince de değerler geliyor. Bu haliyle bile güzel çalışıyor. Çok teşekkür ederim. Gerçi bu problemi de çözersem iyi olur.
Çok inceleyemedim ama, sanırım döviz çeşidini Dolar ve Euro olarak 2 ye de indirmek mümkün. Tekrar teşekkür ederim.
Elinize sağlık.
İyi çalışmalar.
Saygılarımla

samedyücel · 25 Eylül 2014

Korhan bey çok teşekkür ederim elinize sağlık.

em.mehmetaliates · 25 Eylül 2014

Konu ile ilgili gerekli cevap verilmiş fakat bende başka bir yöntem ile çözümden bahsetmek istiyorum.

Dış Veri Al seçeneği ile TCMB dan kur bilgilerini otomatik aldırabilirsiniz.

Veri sekmesinden Web'den (Web'den dış veri al) seçeneğini seçiniz. Yeni web sorgusu başlıklı bir bir sayfa açılacak. Buradan veri almak istediğiniz internet adresini yazınız.Açılan sayfada merkez bankasının kur bilgilerini gösteren alanın yanında bir yatay ok bulunuyor. Buna tıklayın ve Al seçeneğinizi seçin. (sağ altta) Daha sonra veriyi hangi hücreye yerleştirmek istediğinizi soran bir pencere açılıyor. Buraya istediğiniz hücreyi seçtikten sonra bilgi güncellenecektir. Yerletirdiğiniz hücrede sağ tıklayarak veri aralığı özelliklerini seçtiğiniz takdirde bilgilerin ne sıklıkta yenilenmesini istediğinize dair ayarlar mevcuttur.

Bu yöntemin tek sorunu kur değeri 2,2325 ise bunu 22.325 göstermekte. 22.325 değerini başka bir sütunda 10.000'e böldürerek yapabilirsiniz.

İyi çalışmalar.

ZuCChiNi · 29 Eylül 2014

Office 2010'da denedim "Dim X As Variant, Y As Variant, Kontrol As Byte" satırında hata verdi.

Hata Mesajı:
"Duplicate decleration in current scope"

---

Düzeltme: Yanlış satırı değiştirmişim.

samedyücel · 30 Eylül 2014

Merhaba, Merkez Bankası kur ekranında değişiklik yapmış bizimkide şans işte tam oldu derken bu seferde böyle oldu. aynı şekilde uyarlama durumu varmıdır acaba.

ITOKER · 5 Şubat 2016

Merhaba;

aşağıdaki örnek dosyayı çalıştırmak istediğimde aşağıdaki kod kırmızı oluyor ve takılıyor, ne yapmam lazım?

Teşekkürler.

Option Explicit

Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" _
(ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, _
ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long

ITOKER · 5 Şubat 2016

Pardon Örnek dosya yukarıda

T.C.M.B döviz kurlarının otomatik excele aktarımı.

fahrenayt

Ekli dosyalar

Evolver

fahrenayt

Merhum İdris SERDAR

Moderatör

Korhan Ayhan

Administrator

Ekli dosyalar

fahrenayt

Korhan Ayhan

Administrator

Ekli dosyalar

fahrenayt

turgaycakar

samedyücel

Korhan Ayhan

Administrator

Tevfik_Kursun

Korhan Ayhan

Administrator

Tevfik_Kursun

Ekli dosyalar

samedyücel

em.mehmetaliates

ZuCChiNi

samedyücel

ITOKER

ITOKER