aydgur
Altın Üye
- Katılım
- 31 Ekim 2005
- Mesajlar
- 455
- Excel Vers. ve Dili
- Excel 2007 Türkçe
- Altın Üyelik Bitiş Tarihi
- 04-03-2028
İ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
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
