Döviz Kurları (günlük,yıllık,hepsi)

halit3 · 7 Ekim 2014

Bu Çalışmamda ;
Merkez Bankasına ait,

1-Geçerli Döviz Kurları
2-Günlük Döviz Kurları
3-İki tarih arası Döviz Kurları
4-Yıllık Döviz Kurları
5-iki yıl arası Döviz Kurları

Sayfa,sayfalara listelenmektedir.

Ekli iki adet rar dosyasını indirin ve dosyayı rar dan çıkartın.

görsel video

Not :
Gerekmedikce yıllık ve iki yıl arası sorgulama yapmayınız zira bilgisayarınızın performansına göre sorgulama uzun zaman alabilir.

Diğer linkler
http://www.excel.web.tr/f48/doviz-kurlary-gunluk-yyllyk-hepsi-t143688.html
http://www.excel.web.tr/f125/doviz-kurlary-webden-sorgulama-t105168.html#post572862

halit3 · 7 Ekim 2014

İki Tarih arası kurlar için kodlar
Kodları sayfanın kod bölümüne koyun

Tarihler A1 ve B1 hücrelerinde yazılı olması lazım.

Kod:

#If Win64 Then
Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare PtrSafe Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#Else
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If


Private Sub CommandButton1_Click()
URL = "http://www.tcmb.gov.tr"

If (InternetCheckConnection(URL & "/", &H1, 0&) = 0) Then MsgBox "internet bağlantısı yok": Exit Sub

sat = 3
sut = 1
baslangıc = Cells(1, "a")
bitis = Cells(1, "b")


If IsDate(baslangıc) = False Then MsgBox "Başlangıç tarihi yanlış": Exit Sub
If IsDate(bitis) = False Then MsgBox "Bitiş tarihi yanlış": Exit Sub


If CDate(baslangıc) <= CDate(bitis) Then
yer1 = CDate(baslangıc)
yer2 = CDate(bitis)
Else
yer2 = CDate(baslangıc)
yer1 = CDate(bitis)
End If



Rows("2:" & Rows.Count).ClearContents
Rows("2:" & Rows.Count).Interior.ColorIndex = xlNone

Set ie = CreateObject("InternetExplorer.Application")

With ie
.Visible = 1
apiShowWindow ie.hWnd, 6


For M = 0 To Val(yer2 - yer1)
Tarih = yer1 + M


If CDate(Tarih) = CDate(Format(Now, "dd.mm.yyyy")) And "15:30:00" >= CDate(Format(Now, "hh:nn")) Then
GoTo Atla1
End If

If "01.01" = Format((Tarih), "dd/mm") And "23.04" = Format((Tarih), "dd/mm") And "01.05" = Format((Tarih), "dd/mm") And "19.05" = Format((Tarih), "dd/mm") _
And "30.08" = Format((Tarih), "dd/mm") And "28.10" = Format((Tarih), "dd/mm") And "29.10" = Format((Tarih), "dd/mm") Then
GoTo Atla1
End If

If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then
GoTo Atla1
End If



deg1 = Format(Val(Mid(Tarih, 1, 2)), "00")
deg2 = Format(Val(Mid(Tarih, 4, 2)), "00")
deg3 = Format(Val(Mid(Tarih, 7, 4)), "00")

URL1 = "http://www.tcmb.gov.tr/kurlar/" & deg3 & deg2 & "/" & deg1 & deg2 & deg3 & ".xml"

.Navigate URL1

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop


Set html_tba = ie.Document.getElementsByTagName("Body")
adres = Trim(Replace(Replace(Replace(WorksheetFunction.Trim(html_tba(0).InnerText), Chr(13), "  "), Chr(10), "  "), ",", ""))
If Mid(adres, 1, 12) = "Hata - Error" Then
GoTo Atla1
End If
If Mid(adres, 1, 4) = "Hata" Then
GoTo Atla1
End If
If Mid(adres, 2, 4) = "" Then
GoTo Atla1
End If

Cells(sat, sut) = Tarih
Cells(sat, sut).Interior.ColorIndex = 8
Cells(sat, sut).Select
sat = sat + 1

Cells(sat, sut + 1) = "Kısa Slmge"
Cells(sat, sut + 3) = "Döviz Kurları"

Cells(sat, sut + 4).Value = "DÖV.ALŞ"
Cells(sat, sut + 5).Value = "DÖV.STŞ"
Cells(sat, sut + 6).Value = "EFE.ALŞ"
Cells(sat, sut + 7).Value = "EFE.STŞ"



sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(0)

For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 1
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
'Cells(sat, j + 10) = i & " " & j & " " & tbl.Rows(i).Cells(j).innertext
Next
sat = sat + 1
Next
GoTo Atla1

sat = sat + 1
Cells(sat, sut + 1) = "Çapraz Kurlar"
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(1)
For i = 2 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next



sat = sat + 1
If ie.Document.getElementsByTagName("table").Item(2).Rows.Length > 3 Then
ekle = 1
Cells(sat, sut + 1) = "Euro Dönüşüm Kurları"
Else
ekle = 0
Cells(sat, sut + 1) = "Bilgi için"
End If
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(2)
For i = 1 + ekle To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next

If ekle = 1 Then
sat = sat + 2
Cells(sat, sut + 1) = "Bilgi için"
sat = sat + 2
Set tbl = ie.Document.getElementsByTagName("table").Item(3)
For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next
End If

sat = sat + 1
Atla1:

Next M
Columns(sut).EntireColumn.AutoFit
Columns(sut + 1).EntireColumn.AutoFit
Columns(sut + 2).EntireColumn.AutoFit
Columns(sut + 3).EntireColumn.AutoFit
Columns(sut + 4).EntireColumn.AutoFit
Columns(sut + 5).EntireColumn.AutoFit
Columns(sut + 6).EntireColumn.AutoFit
Columns(sut + 7).EntireColumn.AutoFit

ie.Quit: Set ie = Nothing
End With

MsgBox "işlem tamam"
End Sub

halit3 · 7 Ekim 2014

İki yıl arası kurlar için kodlar
Kodları sayfanın kod bölümüne koyun

Kod:

#If Win64 Then
Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare PtrSafe Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#Else
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If

Private Sub CommandButton1_Click()

URL = "http://www.tcmb.gov.tr"
'16.04.1996

If (InternetCheckConnection(URL & "/", &H1, 0&) = 0) Then MsgBox "internet bağlantısı yok": Exit Sub


baslangic1 = Application.InputBox("Başlangıç yılı giriniz.", "Başlangıç yıl", "1996", 400, 30, , Type:=1)
    
If baslangic1 = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

bitis1 = Application.InputBox("Bitiş yılı giriniz.", "Batiş yıl", "2014", 400, 30, , Type:=1)
    
If bitis1 = False Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If


If baslangic1 <= bitis1 Then
baslangic = baslangic1
bitis = bitis1
Else
baslangic = bitis1
bitis = baslangic1
End If


mesaj2 = MsgBox("Kur bilgilerini Almak istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı!")
If mesaj2 = vbNo Then
Exit Sub
End If



mesaj1 = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı!")
If mesaj1 = vbYes Then
Rows("1:" & Rows.Count).ClearContents
Rows("1:" & Rows.Count).Interior.ColorIndex = xlNone
End If

Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = 1
apiShowWindow ie.hWnd, 6

sut = 1

For s = bitis To baslangic Step -1


sat = 2
Cells(1, sut) = s
'Cells(1, sut) = CDate(Format(("01.01." & s), "dd.mm.yyyy"))
'Cells(1, sut + 1) = CDate(Format(("31.12." & s), "dd.mm.yyyy"))

Cells(1, sut).Interior.ColorIndex = 45

yer1 = CDate(Format(("01.01." & s), "dd.mm.yyyy"))
yer2 = CDate(Format(("31.12." & s), "dd.mm.yyyy"))


For M = 0 To Val(yer2 - yer1)
Tarih = yer1 + M


If CDate(Tarih) = CDate(Format(Now, "dd.mm.yyyy")) And "15:30:00" >= CDate(Format(Now, "hh:nn")) Then
GoTo Atla1
End If

If "01.01" = Format((Tarih), "dd/mm") And "23.04" = Format((Tarih), "dd/mm") And "01.05" = Format((Tarih), "dd/mm") And "19.05" = Format((Tarih), "dd/mm") _
And "30.08" = Format((Tarih), "dd/mm") And "28.10" = Format((Tarih), "dd/mm") And "29.10" = Format((Tarih), "dd/mm") Then
GoTo Atla1
End If

If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then
GoTo Atla1
End If



deg1 = Format(Val(Mid(Tarih, 1, 2)), "00")
deg2 = Format(Val(Mid(Tarih, 4, 2)), "00")
deg3 = Format(Val(Mid(Tarih, 7, 4)), "00")

URL1 = "http://www.tcmb.gov.tr/kurlar/" & deg3 & deg2 & "/" & deg1 & deg2 & deg3 & ".xml"
.Navigate URL1

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop


Set html_tba = ie.Document.getElementsByTagName("Body")
adres = Trim(Replace(Replace(Replace(WorksheetFunction.Trim(html_tba(0).InnerText), Chr(13), "  "), Chr(10), "  "), ",", ""))
If Mid(adres, 1, 12) = "Hata - Error" Then
GoTo Atla1
End If
If Mid(adres, 1, 4) = "Hata" Then
GoTo Atla1
End If
If Mid(adres, 1, 4) = "" Then
GoTo Atla1
End If


Cells(sat, sut) = Tarih
Cells(sat, sut).Interior.ColorIndex = 8
Cells(sat, sut).Select
sat = sat + 1

Cells(sat, sut + 1) = "Kısa Slmge"
Cells(sat, sut + 3) = "Döviz Kurları"


Cells(sat, sut + 4).Value = "DÖV.ALŞ"
Cells(sat, sut + 5).Value = "DÖV.STŞ"
Cells(sat, sut + 6).Value = "EFE.ALŞ"
Cells(sat, sut + 7).Value = "EFE.STŞ"


sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(0)

For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 1
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
'Cells(sat, j + 10) = i & " " & j & " " & tbl.Rows(i).Cells(j).innertext
Next
sat = sat + 1
Next

GoTo Atla1
sat = sat + 1
Cells(sat, sut + 1) = "Çapraz Kurlar"
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(1)
For i = 2 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next

sat = sat + 1
If ie.Document.getElementsByTagName("table").Item(2).Rows.Length > 3 Then
ekle = 1
Cells(sat, sut + 1) = "Euro Dönüşüm Kurları"
Else
ekle = 0
Cells(sat, sut + 1) = "Bilgi için"
End If
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(2)
For i = 1 + ekle To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next

If ekle = 1 Then
sat = sat + 2
Cells(sat, sut + 1) = "Bilgi için"
sat = sat + 2
Set tbl = ie.Document.getElementsByTagName("table").Item(3)
For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + sut + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next
End If

sat = sat + 1
Atla1:

Next M

Columns(sut).EntireColumn.AutoFit
Columns(sut + 1).EntireColumn.AutoFit
Columns(sut + 2).EntireColumn.AutoFit
Columns(sut + 3).EntireColumn.AutoFit
Columns(sut + 4).EntireColumn.AutoFit
Columns(sut + 5).EntireColumn.AutoFit
Columns(sut + 6).EntireColumn.AutoFit
Columns(sut + 7).EntireColumn.AutoFit

sut = sut + 8
Next s
ie.Quit: Set ie = Nothing
End With

MsgBox "işlem tamam"
End Sub




Private Sub CommandButton2_Click()

satır = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'Range(Cells(1, 1), Cells(Satır, sutun)).Select
Dim aranan As Date
Dim Rng As Range
aranan2 = InputBox("Aranan kelimeyi yaz", "", "")

If aranan2 = "" Then Exit Sub
If IsDate(aranan2) = False Then MsgBox "Tarih yanlış": Exit Sub
aranan = aranan2
With Range(Cells(1, 1), Cells(satır, sutun))

Set Rng = .Find(What:=aranan, LookIn:=xlFormulas, lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not Rng Is Nothing Then
MsgBox Rng.Cells & Chr(10) & "Satır " & Rng.Row & Chr(10) & "Sutün " & Rng.Column
sonsat = Rng.Row
sonsut = Rng.Column
Rng.Select
'Application.Goto Rng, True

Else
MsgBox "Sonuç yok"
Exit Sub
End If
End With


For r = sonsat + 1 To sonsat + 100
If Cells(r, sonsut) <> "" Then
'MsgBox Cells(r, sonsut)
sonsat1 = r - 1
'MsgBox r - 2
Exit For
End If
Next

For i = sonsat + 1 To sonsat1
For j = sonsut + 1 To sonsut + 7
'MsgBox Cells(i, j)
Next j
Next i

End Sub

Private Sub CommandButton3_Click()
UserForm1.Show 0
End Sub

halit3 · 7 Ekim 2014

Geçerli günlük kurlar için kodlar
Kodları sayfanın kod bölümüne koyun

Kod:

#If Win64 Then
Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare PtrSafe Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#Else
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If


Private Sub CommandButton1_Click()
URL = "http://www.tcmb.gov.tr"


If (InternetCheckConnection(URL & "/", &H1, 0&) = 0) Then MsgBox "internet bağlantısı yok": Exit Sub

Tarih = CDate(Format(Now, "dd.mm.yyyy"))

sat = 3

Tarih1 = Tarih

Set ie = CreateObject("InternetExplorer.Application")
With ie

For M = 0 To 20
Tarih = Tarih1 - M

If CDate(Tarih) = CDate(Format(Now, "dd.mm.yyyy")) And "15:30:00" >= CDate(Format(Now, "hh:nn")) Then
GoTo Atla1
End If

If "01.01" = Format((Tarih), "dd/mm") And "23.04" = Format((Tarih), "dd/mm") And "01.05" = Format((Tarih), "dd/mm") And "19.05" = Format((Tarih), "dd/mm") _
And "30.08" = Format((Tarih), "dd/mm") And "28.10" = Format((Tarih), "dd/mm") And "29.10" = Format((Tarih), "dd/mm") Then
GoTo Atla1
End If

If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then
GoTo Atla1
End If



deg1 = Format(Val(Mid(Tarih, 1, 2)), "00")
deg2 = Format(Val(Mid(Tarih, 4, 2)), "00")
deg3 = Format(Val(Mid(Tarih, 7, 4)), "00")

URL1 = "http://www.tcmb.gov.tr/kurlar/" & deg3 & deg2 & "/" & deg1 & deg2 & deg3 & ".xml"


.Navigate URL1
'.Visible = True
.Visible = 1
'ShowWindow IE.hwnd, 6
apiShowWindow ie.hWnd, 6


Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop


Set html_tba = ie.Document.getElementsByTagName("Body")
'adres = WorksheetFunction.Trim(html_tba(0).InnerText)

adres = Trim(Replace(Replace(Replace(WorksheetFunction.Trim(html_tba(0).InnerText), Chr(13), "  "), Chr(10), "  "), ",", ""))
'adres = Replace(Replace(WorksheetFunction.Trim(html_tba(0).InnerText), Chr(13), "  "), Chr(10), "  ")

If Mid(adres, 1, 12) = "Hata - Error" Then
GoTo Atla1
End If
If Mid(adres, 1, 4) = "Hata" Then
GoTo Atla1
End If
If Mid(adres, 2, 4) = "" Then
GoTo Atla1
End If

Rows("1:5000").ClearContents

sut = 1
Cells(sat, sut) = "Kısa Slmge"
Cells(sat, sut + 2) = "Döviz Kurları"
Cells(sat, sut + 3).Value = "DÖV.ALŞ"
Cells(sat, sut + 4).Value = "DÖV.STŞ"
Cells(sat, sut + 5).Value = "EFE.ALŞ"
Cells(sat, sut + 6).Value = "EFE.STŞ"

sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(0)

For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(i).Cells(j).InnerText
'Cells(sat, j + 10) = i & " " & j & " " & tbl.Rows(i).Cells(j).innertext
Next
sat = sat + 1
Next

Cells(1, "A") = Tarih

Columns(sut).EntireColumn.AutoFit
Columns(sut + 1).EntireColumn.AutoFit
Columns(sut + 2).EntireColumn.AutoFit
Columns(sut + 3).EntireColumn.AutoFit
Columns(sut + 4).EntireColumn.AutoFit
Columns(sut + 5).EntireColumn.AutoFit
Columns(sut + 6).EntireColumn.AutoFit
Columns(sut + 7).EntireColumn.AutoFit


Exit For
sat = sat + 1
Cells(sat, 1) = "Çapraz Kurlar"
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(1)
For i = 2 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next


sat = sat + 1

Cells(sat, 1) = "Bilgi için"
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(2)
For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next


Cells(1, "A") = Tarih

Columns(sut).EntireColumn.AutoFit
Columns(sut + 1).EntireColumn.AutoFit
Columns(sut + 2).EntireColumn.AutoFit
Columns(sut + 3).EntireColumn.AutoFit
Columns(sut + 4).EntireColumn.AutoFit
Columns(sut + 5).EntireColumn.AutoFit
Columns(sut + 6).EntireColumn.AutoFit
Columns(sut + 7).EntireColumn.AutoFit

Exit For
Atla1:

Next M


ie.Quit: Set ie = Nothing
End With

MsgBox "işlem tamam"
End Sub

halit3 · 7 Ekim 2014

İstenen Tarih için kur kodları
Kodları sayfanın kod bölümüne koyun
Tarih A1 hücresinde yazılı olması lazım.

Kod:

#If Win64 Then
Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare PtrSafe Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#Else
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If



Private Sub CommandButton1_Click()

URL = "http://www.tcmb.gov.tr"
If (InternetCheckConnection(URL & "/", &H1, 0&) = 0) Then MsgBox "internet bağlantısı yok": Exit Sub

Tarih = Cells(1, 1).Value

If IsDate(Tarih) = False Then MsgBox "Tarih yanlış": Exit Sub

deg1 = Format(Val(Mid(Tarih, 1, 2)), "00")
deg2 = Format(Val(Mid(Tarih, 4, 2)), "00")
deg3 = Format(Val(Mid(Tarih, 7, 4)), "00")

sat = 3

If CDate(Tarih) = CDate(Format(Now, "dd.mm.yyyy")) And "15:30:00" >= CDate(Format(Now, "hh:nn")) Then
MsgBox "Bugün işlem yok"
GoTo Atla1
End If

If "01.01" = Format((Tarih), "dd/mm") And "23.04" = Format((Tarih), "dd/mm") And "01.05" = Format((Tarih), "dd/mm") And "19.05" = Format((Tarih), "dd/mm") _
And "30.08" = Format((Tarih), "dd/mm") And "28.10" = Format((Tarih), "dd/mm") And "29.10" = Format((Tarih), "dd/mm") Then
MsgBox "Bayram Tatili"
GoTo Atla1
End If

If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then
MsgBox "Hafta sonu"
GoTo Atla1
End If



URL1 = "http://www.tcmb.gov.tr/kurlar/" & deg3 & deg2 & "/" & deg1 & deg2 & deg3 & ".xml"

Set ie = CreateObject("InternetExplorer.Application")
With ie
.Navigate URL1
.Visible = 1
apiShowWindow ie.hWnd, 6
'On Error Resume Next
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
Do Until ie.ReadyState = 4: DoEvents: Loop


Set html_tba = ie.Document.getElementsByTagName("Body")
adres = Trim(Replace(Replace(Replace(WorksheetFunction.Trim(html_tba(0).InnerText), Chr(13), "  "), Chr(10), "  "), ",", ""))
If Mid(adres, 1, 12) = "Hata - Error" Then
GoTo Atla1
End If
If Mid(adres, 1, 4) = "Hata" Then
GoTo Atla1
End If
If Mid(adres, 1, 4) = "" Then
GoTo Atla1
End If


Rows("2:5000").ClearContents
Rows("2:5000").Interior.ColorIndex = xlNone
sut = 1
Cells(sat, sut) = "Kısa Slmge"
Cells(sat, sut + 2) = "Döviz Kurları"
Cells(sat, sut + 3).Value = "DÖV.ALŞ"
Cells(sat, sut + 4).Value = "DÖV.STŞ"
Cells(sat, sut + 5).Value = "EFE.ALŞ"
Cells(sat, sut + 6).Value = "EFE.STŞ"


sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(0)

For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(i).Cells(j).InnerText
'Cells(sat, j + 10) = i & " " & j & " " & tbl.Rows(i).Cells(j).innertext
Next
sat = sat + 1
Next

Columns(sut).EntireColumn.AutoFit
Columns(sut + 1).EntireColumn.AutoFit
Columns(sut + 2).EntireColumn.AutoFit
Columns(sut + 3).EntireColumn.AutoFit
Columns(sut + 4).EntireColumn.AutoFit
Columns(sut + 5).EntireColumn.AutoFit
Columns(sut + 6).EntireColumn.AutoFit
Columns(sut + 7).EntireColumn.AutoFit
GoTo Atla1


sat = sat + 2
Cells(sat, 1) = "Çapraz Kurlar"
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(1)
For i = 2 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next


sat = sat + 2


If ie.Document.getElementsByTagName("table").Item(2).Rows.Length > 3 Then
ekle = 1
Cells(sat, 1) = "Euro Dönüşüm Kurları"
Else
ekle = 0
Cells(sat, 1) = "Bilgi için"
End If


sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(2)

For i = 1 + ekle To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next

If ekle = 1 Then

sat = sat + 2

Cells(sat, 1) = "Bilgi için"
sat = sat + 2

Set tbl = ie.Document.getElementsByTagName("table").Item(3)
For i = 1 To tbl.Rows.Length - 1
For j = 0 To tbl.Rows(i).Cells.Length - 2
Cells(sat, j + 1) = tbl.Rows(i).Cells(j).InnerText
Next
sat = sat + 1
Next
End If

Columns(sut).EntireColumn.AutoFit
Columns(sut + 1).EntireColumn.AutoFit
Columns(sut + 2).EntireColumn.AutoFit
Columns(sut + 3).EntireColumn.AutoFit
Columns(sut + 4).EntireColumn.AutoFit
Columns(sut + 5).EntireColumn.AutoFit
Columns(sut + 6).EntireColumn.AutoFit
Columns(sut + 7).EntireColumn.AutoFit


Atla1:

ie.Quit: Set ie = Nothing
End With
MsgBox "işlem tamam"

End Sub

halit3 · 7 Ekim 2014

Userform için kod ve nesneler.

1- adet CommandButton nesnesi
1- adet TextBox nesnesi
1-adet ListView1 nesnesi

not :bu userform kodları iki yıl arası sorgulama kod ile ilgili sayfada çalışmaktadır.

kod:

Kod:

Private Sub CommandButton1_Click()
satır = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'Range(Cells(1, 1), Cells(Satır, sutun)).Select
Dim aranan As Date
Dim Rng As Range
deg1 = 0

If TextBox1.Text = "" Then Exit Sub
If IsDate(TextBox1.Text) = False Then MsgBox "Tarih yanlış": Exit Sub

aranan = TextBox1.Text 'InputBox("Aranan kelimeyi yaz", "", "")



If Trim(aranan) <> "" Then

With Range(Cells(1, 1), Cells(satır, sutun))

Set Rng = .Find(What:=aranan, LookIn:=xlFormulas, lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not Rng Is Nothing Then
'MsgBox Rng.Cells & Chr(10) & "Satır " & Rng.Row & Chr(10) & "Sutün " & Rng.Column
sonsat = Rng.Row
sonsut = Rng.Column
'Rng.Select
'Application.Goto Rng, True

Else
MsgBox "Sonuç yok"
deg1 = 1
End If
End With
End If

If deg1 = 0 Then
ListView1.ListItems.Clear

For r = sonsat + 1 To sonsat + 100
If Cells(r, sonsut) <> "" Then
'MsgBox Cells(r, sonsut)
sonsat1 = r - 1
'MsgBox r - 2
Exit For
End If

Next

For i = sonsat + 1 To sonsat1
x = x + 1
ListView1.ListItems.Add , , i
With ListView1.ListItems(x).ListSubItems
y = 0
For j = sonsut + 1 To sonsut + 7
y = y + 1
.Add , , Cells(i, j)
Next j
End With
Next i
End If
End Sub

Private Sub UserForm_Initialize()

ReDim say(8)


With ListView1
.ListItems.Clear
.ColumnHeaders.Clear
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
.LabelEdit = lvwManual
.AllowColumnReorder = True
'.ForeColor = 16711680
'.Font.Bold = True
'.ForeColor = &HFF&   '&H0&
.Font.Bold = True
With .ColumnHeaders
.Add , , "Satır no", 45
.Add , , "Sut 1", 63
.Add , , "Sut 2", 30
.Add , , "Sut 3", 120
.Add , , "Sut 4", 45
.Add , , "Sut 5", 45
.Add , , "Sut 6", 45
.Add , , "Sut 7", 45

End With
End With


End Sub

halit3 · 8 Ekim 2014

Dosya güncelledi

Hingel · 8 Ekim 2014

Merhaba,
Altın üyeliği olmayanlar için de dosyayı indirebilecek bir yere atabilirmisiniz.

halit3 · 8 Ekim 2014

Hingel' Alıntı:
Merhaba,
Altın üyeliği olmayanlar için de dosyayı indirebilecek bir yere atabilirmisiniz.

Ben dosyaları ve kodları farklı sitelere yüklemiyorum buradan dosyaları indiremeyenler için kodları da ekliyorum.

Kodlar 2. mesajdan 6.mesaja kadar olan bölümlerde mevcut

Hingel · 8 Ekim 2014

Cevap için teşekkürler,
Bu kodları Excel 2007'de çalıştırmak için ek bir işlem yapmam gerekiyor mu? Bu şekliyle başarılı olamadım, bu konuda iyi değilim zaten.

halit3 · 8 Ekim 2014

görsel video yükleniyor

ara ara deneyiniz.

görsel video

Hingel · 8 Ekim 2014

Zahmet oldu teşekkürler

halit3 · 8 Ekim 2014

Hingel' Alıntı:
Zahmet oldu teşekkürler

video yüklendi

halit3 · 9 Ekim 2014

Hingel' Alıntı:
Zahmet oldu teşekkürler

Görsel videoyu indirebildinizmi

Hingel · 9 Ekim 2014

Video'yu aldım, gösterdiğiniz şekilde düğmeleri de ekledim teşekkür ederim. Yalnız iki tarih arasında kurları alırken bir hata alıyorum (diğerlerini yoğunluktan deneyemedim), ilk günün kurlarını getiriyor sonra internet explorer penceresi ekrana geliyor orada ikinci günün kurlarını gösteriyor ve kapanmıyor, explorerı kapatınca da Automation error veriyor.

halit3 · 9 Ekim 2014

Hingel' Alıntı:
Video'yu aldım, gösterdiğiniz şekilde düğmeleri de ekledim teşekkür ederim. Yalnız iki tarih arasında kurları alırken bir hata alıyorum (diğerlerini yoğunluktan deneyemedim), ilk günün kurlarını getiriyor sonra internet explorer penceresi ekrana geliyor orada ikinci günün kurlarını gösteriyor ve kapanmıyor, explorerı kapatınca da Automation error veriyor.

2 nolu mesajdaki kodu güncelledim yeniden deneyiniz.

Hingel · 9 Ekim 2014

Aynı sorunu verdi, debug dediğimde Do Until ie.ReadyState = 4 satırını göstermekte.

alperentug · 9 Ekim 2014

tcmb döviz kurları

Halit3 üstadım döviz kurları ile ilgili bir excell dosyam var ama size nasıl ulaştırabilirim.

halit3 · 9 Ekim 2014

alperentug' Alıntı:
Halit3 üstadım döviz kurları ile ilgili bir excell dosyam var ama size nasıl ulaştırabilirim.

Merhaba bana niye göndermek istiyorsunuz anlayamadım ?

Dosyanız ile bir sorunuz varsa farklı sitelere yükleyip yeni bir konu açarak farklı bir başlık altında sorunuzu sorun ve eklemiş olduğunuz dosyaya ait de linkini ekleyin.

halit3 · 9 Ekim 2014

Hingel' Alıntı:
Aynı sorunu verdi, debug dediğimde Do Until ie.ReadyState = 4 satırını göstermekte.

Herhalde internet explorer tarayıcı ile bir sıkıntı var göndermiş olduğum videoda bende çalışıyor.

Bu kodların çalışması için internet explorer tarayıcısı mutlaka olması lazım.

Döviz Kurları (günlük,yıllık,hepsi)

halit3

Uzman

Ekli dosyalar

halit3

Uzman

halit3

Uzman

halit3

Uzman

halit3

Uzman

halit3

Uzman

halit3

Uzman

Hingel

halit3

Uzman

Hingel

halit3

Uzman

Hingel

halit3

Uzman

halit3

Uzman

Hingel

halit3

Uzman

Hingel

alperentug

halit3

Uzman

halit3

Uzman