Tcmb den kur çekme

[aydgur]

İyi günler , aşağıdakigibi bir kodum var , bununla RAPOR sayfasına tcmb kurlarını getirebiliyorum fakat bu işlem abartısız 20 dakika sürüyor.
Yerine kullanabileceğim yada bozduğum bir sdatır mı var acaba ?
Sub SORGULAMAK()
Application.ScreenUpdating = False
Set SR = Sheets("RAPOR")
SR.Select
If [B1] = "" Then MsgBox "Lütfen ilk tarihi giriniz!", vbExclamation, "Dikkat!": [B1].Select: Exit Sub
If [B2] = "" Then MsgBox "Lütfen son tarihi giriniz!", vbExclamation, "Dikkat!": [B2].Select: Exit Sub
If [B2] < [B1] Then
S2.Cells(sonsatir, "l") = S1.Cells(satırr, "l")

[B2].ClearContents
[B2].Select
Exit Sub
End If

[A6:I65536].ClearContents

On Error Resume Next
Application.DisplayAlerts = False
Sheets("KURLAR").Delete
Application.DisplayAlerts = True

Sheets.Add
Sayfa_Adı = "KURLAR"
ActiveSheet.Name = Sayfa_Adı
Set SK = Sheets(Sayfa_Adı)

With Application
.DecimalSeparator = "."
.ThousandsSeparator = ","
.UseSystemSeparators = False
End With


SR.Select
BEKLEME.Show
Application.Wait (Now + TimeValue("0:00:01"))

TOPLAM_SATIR_SAYISI = (SR.[B2] - 1) - (SR.[B1] - 1) + 1

For X = SR.[B1] - 1 To SR.[B2] - 1
If X > Date - 1 Then Exit For

SATIR_SAYISI = SATIR_SAYISI + 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) & ".xml"

With SK.QueryTables.Add(Connection:=URL1, Destination:=SK.Range("A1"))
.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

SATIR = SR.[A65536].End(3).Row + 1
If SK.[A1] <> "" Then
EURO = SK.[A:A].Find(What:="EUR", LookAt:=xlPart).Row
USD = SK.[A:A].Find(What:="USD", LookAt:=xlPart).Row
SR.Cells(SATIR, 1) = X
SR.Cells(SATIR, 2) = IIf(Left(SK.Cells(EURO, 4), 1) = 0, Replace(SK.Cells(EURO, 4), ".", ",") * 1, SK.Cells(EURO, 4))
SR.Cells(SATIR, 3) = IIf(Left(SK.Cells(EURO, 5), 1) = 0, Replace(SK.Cells(EURO, 5), ".", ",") * 1, SK.Cells(EURO, 5))
SR.Cells(SATIR, 4) = IIf(Left(SK.Cells(EURO, 6), 1) = 0, Replace(SK.Cells(EURO, 6), ".", ",") * 1, SK.Cells(EURO, 6))
SR.Cells(SATIR, 5) = IIf(Left(SK.Cells(EURO, 7), 1) = 0, Replace(SK.Cells(EURO, 7), ".", ",") * 1, SK.Cells(EURO, 7))
SR.Cells(SATIR, 6) = IIf(Left(SK.Cells(USD, 4), 1) = 0, Replace(SK.Cells(USD, 4), ".", ",") * 1, SK.Cells(USD, 4))
SR.Cells(SATIR, 7) = IIf(Left(SK.Cells(USD, 5), 1) = 0, Replace(SK.Cells(USD, 5), ".", ",") * 1, SK.Cells(USD, 5))
SR.Cells(SATIR, 8) = IIf(Left(SK.Cells(USD, 6), 1) = 0, Replace(SK.Cells(USD, 6), ".", ",") * 1, SK.Cells(USD, 6))
SR.Cells(SATIR, 9) = IIf(Left(SK.Cells(USD, 7), 1) = 0, Replace(SK.Cells(USD, 7), ".", ",") * 1, SK.Cells(USD, 7))
End If

For Z = X To X - 7 Step -1
If SK.[A1] <> "" Then GoTo Devam
KONTROL = Weekday(Z, vbMonday)
If KONTROL > 5 Then
Y = Z - (KONTROL - 5)
Else
Y = Z
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) & ".xml"

With SK.QueryTables.Add(Connection:=URL1, Destination:=SK.Range("A1"))
.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

SATIR = SR.[A65536].End(3).Row + 1
If SK.[A1] <> "" Then
EURO = SK.[A:A].Find(What:="EUR", LookAt:=xlPart).Row
USD = SK.[A:A].Find(What:="USD", LookAt:=xlPart).Row
SR.Cells(SATIR, 1) = X
SR.Cells(SATIR, 2) = IIf(Left(SK.Cells(EURO, 4), 1) = 0, Replace(SK.Cells(EURO, 4), ".", ",") * 1, SK.Cells(EURO, 4))
SR.Cells(SATIR, 3) = IIf(Left(SK.Cells(EURO, 5), 1) = 0, Replace(SK.Cells(EURO, 5), ".", ",") * 1, SK.Cells(EURO, 5))
SR.Cells(SATIR, 4) = IIf(Left(SK.Cells(EURO, 6), 1) = 0, Replace(SK.Cells(EURO, 6), ".", ",") * 1, SK.Cells(EURO, 6))
SR.Cells(SATIR, 5) = IIf(Left(SK.Cells(EURO, 7), 1) = 0, Replace(SK.Cells(EURO, 7), ".", ",") * 1, SK.Cells(EURO, 7))
SR.Cells(SATIR, 6) = IIf(Left(SK.Cells(USD, 4), 1) = 0, Replace(SK.Cells(USD, 4), ".", ",") * 1, SK.Cells(USD, 4))
SR.Cells(SATIR, 7) = IIf(Left(SK.Cells(USD, 5), 1) = 0, Replace(SK.Cells(USD, 5), ".", ",") * 1, SK.Cells(USD, 5))
SR.Cells(SATIR, 8) = IIf(Left(SK.Cells(USD, 6), 1) = 0, Replace(SK.Cells(USD, 6), ".", ",") * 1, SK.Cells(USD, 6))
SR.Cells(SATIR, 9) = IIf(Left(SK.Cells(USD, 7), 1) = 0, Replace(SK.Cells(USD, 7), ".", ",") * 1, SK.Cells(USD, 7))
End If

DoEvents
Next
Devam:
Next

Application.DisplayAlerts = False
SK.Delete
Application.DisplayAlerts = True

With Application
.DecimalSeparator = ","
.ThousandsSeparator = "."
.UseSystemSeparators = False
End With
Sheets("DURUM").Select
[A1].Select
Application.ScreenUpdating = True
Unload BEKLEME
MsgBox "Günlük T.C.M.B.Döviz Satış Kurları Çekilmiştir", vbInformation
Application.ScreenUpdating = True
End Sub
Sub AUTO_OPEN()
Worksheets("DURUM").Select
Beep
MsgBox "Önce Kurları Çekelim mi ? ", vbInformation, " M.B.Satış Kurları"
Sheets("DURUM").Select
[A1].Select

Range("B5").Select
End Sub

 

[Ömer BARAN]

Merhaba.

Açtığınız konu, forumda çokça işlenmiş, birçok alternatif kullanım/kod yöntemleriyle çözümler ve örnek dosyalar da paylaşılmış bir konu.
Forum sayfalarının sağ üst kısmındaki ARA bölümünü kullanabilirsiniz.

Örneğin aşağıdaki konu sayfasında, açılış mesajındaki iki örnek belgeyi inceleyibilirsiniz.
İkinci belge sizin istediğiniz LİSTELEME, ilk belge ise farklı bir uygulamayı içeriyor.

KTF: Belli Tarih, Seçilen Döviz/Kur Türü TCMB Kuru /// İki Tarih Arası Kur Listeleme
.