[Murat OSMA]

Yenilenen TCMB sayfasından günlük döviz kurlarını ve çarpraz kur bilgilerini almak için kullanabilirsiniz.

[Tarkan VURAL]

Fonksiyonla tarih bazında, hücre içine tek tek belirli bir döviz kurunu almak için aşağıdaki KTF kullanılabilir.

Kullanımı:

Kod: Tümünü seç

=WebDoviz(Tarih Parametresi, Döviz Cinsi Parametresi, Döviz Değer Parametresi)

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

Kod: Tümünü seç

DefVar E
Function Webdoviz(ByVal Tarih As Date, ByVal Dovtip As String, ByVal Tipi As Long) As Variant
Dim gun As String, ay As String, yil As String, path As String, kur As Double
Dim icerik As String, xmlhttp As Object, evn As Variant
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
Application.Volatile
Dovtip = UCase(Dovtip)
gun = Day(Tarih): ay = Month(Tarih): yil = Year(Tarih)
If Len(gun) = 1 Then gun = "0" & gun
If Len(ay) = 1 Then ay = "0" & ay
path = "http://www.tcmb.gov.tr/kurlar/" & yil & ay & "/" & gun & ay & yil & ".xml"
xmlhttp.Open "GET", path, False
xmlhttp.send "at"
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>")
            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), "</")
            End Select
            Exit For
        End If
    Next y
End If
'Kuruş hanesini benim gibi virgül kullananlar için
Webdoviz = Replace(evn(0), ".", ",")

'Kuruş hanesini nokta kullananlar için
'Webdoviz = evn(0)
End Function


y	A	B	C	D	E	F	G	H	I
1	Tarih	Usd Döviz Alış	Usd Döviz Satış	Usd Efektif Alış	Usd Efektif Satış	Euro Döviz Alış	Euro Döviz Satış	Euro Efektif Alış	Euro Efektif Satış
2	29.09.2014	2.2789	2.283	2.2773	2.2864	2.8914	2.8966	2.8894	2.9009
3	30.09.2014

Hücre	Formül
B2	=Webdoviz(A2;"usd";1)
C2	=Webdoviz(A2;"usd";2)
D2	=Webdoviz(A2;"usd";3)
E2	=Webdoviz(A2;"usd";4)
F2	=Webdoviz(A2;"eur";1)
G2	=Webdoviz(A2;"eur";2)
H2	=Webdoviz(A2;"eur";3)
I2	=Webdoviz(A2;"eur";4)

[otobus]

Tarkan hocam
linkteki bağlantıdan kopyaladığımda kodu çalıştıramadım. ( benim kod bilgimden kaynaklıdır)
Ayrıca çıkan sonuçları 10000 e böldüğümde gerçek kur değerine ulaşıyorum.
ne yapmak lazım?
sizden ricam tam kodu buraya yapıştırabilir misiniz?

Şimdiden teşekkürler
saygılar

[gkhnylcn]

Yenilenen TCMB sayfasından günlük döviz kurlarını ve çarpraz kur bilgilerini almak için kullanabilirsiniz.

kur.png

Merhaba Murat bey,

Öncelikle emeğinize sağlık.
Acaba bu excel dosyanın içine bir takvim ya da tarih seçme alanı koyup, içerisinden seçtiğimiz tarihe ait TCMB kurlarını aynen sizin tablonuzda aldığınız gibi almak mümkün müdür? Daha da açık söylemem gerekirse, mesela 15/08/2014 tarihli TCMB kurlarına ihtiyacım var. Tarihi işaretleyip "Güncelle" butonunu tıkladığımda o tarihe ait kurlar tablo halinde gelsin istiyorum.
Mümkün müdür?

Şimdiden teşekkür ederim.

[Tarkan VURAL]

Fonksiyondaki hatalı kısım güncellenmiş olup örnek dosya eklenmiştir.

y	A	B	C	D	E	F
1	Tarih	Döviz	Alış	Satış	Ef.Alış	Ef.Satış
2	29.09.2014	usd	2,2789	2,283	2,2773	2,2864
3	29.09.2014	eur	2,8914	2,8966	2,8894	2,9009
4	29.09.2014	gbp	3,6933	3,7125	3,6907	3,7181
5	29.09.2014	nok	0,35198	0,35435	0,35173	0,35517
6	29.09.2014	dkk	0,38784	0,38975	0,38757	0,39065
7	29.09.2014	ron	0,6517	0,66023

Hücre	Formül
C2	=webdoviz($A2;$B2;1)
D2	=webdoviz($A2;$B2;2)
E2	=webdoviz($A2;$B2;3)
F2	=webdoviz($A2;$B2;4)
C3	=webdoviz($A3;$B3;1)
D3	=webdoviz($A3;$B3;2)
E3	=webdoviz($A3;$B3;3)
F3	=webdoviz($A3;$B3;4)
C4	=webdoviz($A4;$B4;1)
D4	=webdoviz($A4;$B4;2)
E4	=webdoviz($A4;$B4;3)
F4	=webdoviz($A4;$B4;4)
C5	=webdoviz($A5;$B5;1)
D5	=webdoviz($A5;$B5;2)
E5	=webdoviz($A5;$B5;3)
F5	=webdoviz($A5;$B5;4)
C6	=webdoviz($A6;$B6;1)
D6	=webdoviz($A6;$B6;2)
E6	=webdoviz($A6;$B6;3)
F6	=webdoviz($A6;$B6;4)
C7	=webdoviz($A7;$B7;1)
D7	=webdoviz($A7;$B7;2)
E7	=webdoviz($A7;$B7;3)
F7	=webdoviz($A7;$B7;4)

[otobus]

Çok teşekkür ederim, saygılarımla.

[gkhnylcn]

Merhaba Tarkan bey,

Bahsettiğiniz şekilde bütün kurları getirmeye çalıştığımda "DKK" ve "RON" değerleri aynı geliyor.
Fakat bu formülle değil de TCMB sitesi ile alakalı, değil mi?

[Uygaroz]

Murat Bey
Ellerinize sağlık makro çok güzel çalışıyor.
Sizden şöyle bir ricam olabilir mi?

Makro saat 15:45 gibi kendi çalışsa. Tcmb kurları her gün 15:30 da yenileniyor.
Yada; her saat başı / 2 saatte bir, kendi otomatik yenilese.
Teşekkürler
Uygar

[Tarkan VURAL]

Merhaba Tarkan bey,

Bahsettiğiniz şekilde bütün kurları getirmeye çalıştığımda "DKK" ve "RON" değerleri aynı geliyor.
Fakat bu formülle değil de TCMB sitesi ile alakalı, değil mi?

Hayır, TCMB ile alakalı değil, koddaki gözümden kaçan bir ayrıntıdan kaynaklanıyor.
İlgili kod ve dosya üst mesajda güncellenmiştir. Uyarınız için teşekkür ediyorum.

Bilginize.

[Murat OSMA]

Murat Bey
Ellerinize sağlık makro çok güzel çalışıyor.
Sizden şöyle bir ricam olabilir mi?

Makro saat 15:45 gibi kendi çalışsa. Tcmb kurları her gün 15:30 da yenileniyor.
Yada; her saat başı / 2 saatte bir, kendi otomatik yenilese.
Teşekkürler
Uygar

Merhaba Uygar Bey,

Module içerisine bu kodu ilave edin;

Kod: Tümünü seç

Sub Auto_Open()
    Application.OnTime TimeValue("15:45:00"), "Makro_Adı"
End Sub

Makro_Adı yazan yere sorgulama kodundaki makro adını yazın. Saat 15:45:00 da makro alışacak ve tekrar güncelleme yapacaktır.

Not: Bu işlemi yapabilmesi için dosyanın açık olması gerekmekte.

[Uygaroz]

Murat bey
Ellerinize sağlık.
İyi akşamlar dilerim.
Uygar

[Murat OSMA]

İyi akşamlar Uygar Bey...

[Terazi]

Merhaba,

İlk mesajdaki Murat Osma bey'in eklediği dosyadaki makroyu çalıştırdığımda;
USD/PKR 1 ABD DOLARI 0,0103 PAKİSTAN RUPİSİ
sonucunu alıyorum...

Halbuki;
USD/PKR 1 ABD DOLARI 102,56 PAKİSTAN RUPİSİ
olması lazım...

Bilginize...

[Murat OSMA]

Merhaba Mehmet Bey,

Sitedeki verileri formatlarından kaynaklanıyor. Aynı durum USD/JPY de de mevcut. İlaveten en alt tablodaki SDR/USD formatı da farklı olduğundan hatalı geliyor. Bu formatları düzenlemek gerek..

Kodları revize ettim. Bu kodları kullanabilirsiniz;

Kod: Tümünü seç

Sub Emre()
    Application.ScreenUpdating = False
    Dim alan As Range
    Cells.Clear
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.tcmb.gov.tr/kurlar/today.xml", Destination:=Range("$A$1"))
        .Name = "today_1"
        .Refresh BackgroundQuery:=False
    End With
    Range("AB1000").Value = "10000"
    Range("AB1000").Copy
    Set alan = Range("D3:G20,D25:D41,D44:D45")
    alan.Select
    For Each evn In alan
    If Left(evn.Value, 2) = 10 Then
        evn.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        evn.Value = CDbl(evn.Value)
    ElseIf Left(evn.Value, 1) > 0 Then
        evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
            ElseIf Left(evn.Value, 1) = 0 Then
        evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
        evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
    End If
    Next evn
    Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Application.CutCopyMode = False
    Columns("D:G").NumberFormat = "#,##0.0000"
    Range("D44").Value = Range("D44").Value / 10
    Range("D44").NumberFormat = "#,##0.00000"
    Cells.Font.Size = 8: Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

[Terazi]

Merhaba,
USD/IRR 1 ABD DOLARI 2,6668 İRAN RİYALİ
değil,
USD/IRR 1 ABD DOLARI 26668 İRAN RİYALİ
olması lazım...
Bilginize...

[Murat OSMA]

Başka hata varsa onları da tek bir mesajda toplayın üzerinde son bir işlem yapıp bitirelim.

[Terazi]

Merhaba,
USD/RUB 1 ABD DOLARI 0,0040 RUS RUBLESİ
değil,
USD/RUB 1 ABD DOLARI 39,65 RUS RUBLESİ
olması lazım...
Bilginize...

[Uygaroz]

Murat Bey
Makro kullanmadan, "Dış Veri Al" ile kurları çektiğimiz zaman kurlar;
2,2865 yerine 22.865 şeklinde gelmektedir.
Bunun bir çözümü var mı acaba?
Selamlar
Uygar

[Murat OSMA]

Mehmet Bey bu kodları kullanabilirsiniz;

Kod: Tümünü seç

Sub Emre()
    Application.ScreenUpdating = False
    Dim alan As Range
    Cells.Clear
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.tcmb.gov.tr/kurlar/today.xml", Destination:=Range("$A$1"))
        .Name = "today_1"
        .Refresh BackgroundQuery:=False
    End With
    Range("AB1000").Value = "10000"
    Range("AB1000").Copy
    Set alan = Range("D3:G20")
    alan.Select
    For Each evn In alan
        If Left(evn.Value, 2) = 10 Then
            evn.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
            evn.Value = CDbl(evn.Value)
        ElseIf Left(evn.Value, 1) > 0 Then
            evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
        ElseIf Left(evn.Value, 1) = 0 Then
            evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
            evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
        End If
    Next evn
    Range("D25:D26,D28,D30:D37,D40").PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
    Range("D27,D29,D38,D41").Replace What:=".", Replacement:=","
    Range("D44").Value = Range("D44").Value / 100000
    Range("D45").Value = Range("D45").Value / 10000
    Range("D25:D41").HorizontalAlignment = xlRight
    Application.CutCopyMode = False
    Columns("D:G").NumberFormat = "#,##0.0000"
    Range("D44").NumberFormat = "#,##0.00000"
    Range("D39").NumberFormat = "#,##0"
    Cells.Font.Size = 8: Columns.AutoFit: Range("A1").Select
    Application.ScreenUpdating = True
End Sub


[Tarkan VURAL]

Basamak ayracınızı virgül yerine nokta yaparak deneyin bakalım işinizi çözecek mi ?

2003
Araçlar - Seçenekler - Uluslararası sekmesinden;

2007
Office logosu - Excel Seçenekleri - Gelişmiş - Düzenleme seçenekleri kısmından;

2010-2013
Dosya - Seçenekler/Excel Seçenekleri - Gelişmiş - Düzenleme seçenekleri kısmından değiştirebilirsiniz.