tcmb kurları

Katılım
27 Mart 2010
Mesajlar
0
Beğeniler
0
Excel Vers. ve Dili
2007
#1
arkadaşlar merhaba ;

Ekteki Dosyada sorgula dediğimde kurlar geliyordu şimdi ise hiç bişey gelmiyor.

Düzeltme yapabilir misiniz lütfe

Kod:
Sub SORGULA()
    Application.ScreenUpdating = False
    Set SR = Sheets("RAPOR")
    SR.Select
    If [B1] = "" Then MsgBox "LÜTFEN İLK TARİHİ GİRİNİZ !", vbExclamation, "DİKKAT !": [B1].Select: Exit Sub
    If [B2] = "" Then MsgBox "LÜTFEN SON TARİHİ GİRİNİZ !", vbExclamation, "DİKKAT !": [B2].Select: Exit Sub
    If [B2] < [B1] Then
    MsgBox "SON TARİH İLK TARİHTEN KÜÇÜK OLAMAZ !" _
    & Chr(10) & Chr(10) & "LÜTFEN GİRDİĞİNİZ BİLGİLERİ KONTROL EDİNİZ.", vbCritical, "DİKKAT !"
    [B2].ClearContents
    [B2].Select
    Exit Sub
    End If
    
    [A6:O65536].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
    
    For X = SR.[B1] To SR.[B2]
    If X > Date Then Exit For
    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/TRY", LookAt:=xlPart).Row
    USD = SK.[A:A].Find(What:="USD/TRY", LookAt:=xlPart).Row
    GBP = SK.[A:A].Find(What:="GBP/TRY", LookAt:=xlPart).Row
    EURUSD = SK.[A:A].Find(What:="EUR/USD", LookAt:=xlPart).Row
    GBPUSD = SK.[A:A].Find(What:="GBP/USD", LookAt:=xlPart).Row
    
    If y < 39925 And y > 40276 Then
    q1 = 3: q2 = 4: q3 = 5: q4 = 6
    
        Dim j, k, p, s, l()
        p = "": k = Len(SK.Cells(EURUSD, 3))
        ReDim l(k)
        For j = 1 To k
        l(j) = Mid(SK.Cells(EURUSD, 3), j, 1)
        If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
        l(j) = l(j)
        Else
        l(j) = ""
        End If
        
        If l(j) = "," Then
        l(j) = "."
        End If
        
        p = p & l(j)
        Next
        
        s = "": k = Len(SK.Cells(GBPUSD, 3))
        ReDim l(k)
        For j = 1 To k
        l(j) = Mid(SK.Cells(GBPUSD, 3), j, 1)
        If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
        l(j) = l(j)
        Else
        l(j) = ""
        End If
        
        If l(j) = "," Then
        l(j) = "."
        End If
        
        s = s & l(j)
        Next
    
    Else
    q1 = 4: q2 = 5: q3 = 6: q4 = 7
    p = SK.Cells(EURUSD, 4)
    s = SK.Cells(GBPUSD, 4)
    End If
        
    SR.Cells(SATIR, 1) = X
    SR.Cells(SATIR, 2) = SK.Cells(USD, q1)
    SR.Cells(SATIR, 3) = SK.Cells(USD, q2)
    SR.Cells(SATIR, 4) = SK.Cells(USD, q3)
    SR.Cells(SATIR, 5) = SK.Cells(USD, q4)
    SR.Cells(SATIR, 6) = SK.Cells(EURO, q1)
    SR.Cells(SATIR, 7) = SK.Cells(EURO, q2)
    SR.Cells(SATIR, 8) = SK.Cells(EURO, q3)
    SR.Cells(SATIR, 9) = SK.Cells(EURO, q4)
    SR.Cells(SATIR, 10) = SK.Cells(GBP, q1)
    SR.Cells(SATIR, 11) = SK.Cells(GBP, q2)
    SR.Cells(SATIR, 12) = SK.Cells(GBP, q3)
    SR.Cells(SATIR, 13) = SK.Cells(GBP, q4)
    SR.Cells(SATIR, 14) = p
    SR.Cells(SATIR, 15) = s
    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/TRY", LookAt:=xlPart).Row
    USD = SK.[A:A].Find(What:="USD/TRY", LookAt:=xlPart).Row
    GBP = SK.[A:A].Find(What:="GBP/TRY", LookAt:=xlPart).Row
    EURUSD = SK.[A:A].Find(What:="EUR/USD", LookAt:=xlPart).Row
    GBPUSD = SK.[A:A].Find(What:="GBP/USD", LookAt:=xlPart).Row
    
    If y < 39925 Or y > 40276 Then
    q1 = 3: q2 = 4: q3 = 5: q4 = 6
        
        'Dim j, k, p, s, l()
        p = "": k = Len(SK.Cells(EURUSD, 3))
        ReDim l(k)
        For j = 1 To k
        l(j) = Mid(SK.Cells(EURUSD, 3), j, 1)
        If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
        l(j) = l(j)
        Else
        l(j) = ""
        End If
        
        If l(j) = "," Then
        l(j) = "."
        End If
        
        p = p & l(j)
        Next
        
        s = "": k = Len(SK.Cells(GBPUSD, 3))
        ReDim l(k)
        For j = 1 To k
        l(j) = Mid(SK.Cells(GBPUSD, 3), j, 1)
        If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
        l(j) = l(j)
        Else
        l(j) = ""
        End If
        
        If l(j) = "," Then
        l(j) = "."
        End If
        
        s = s & l(j)
        Next
    
    Else
    q1 = 4: q2 = 5: q3 = 6: q4 = 7
    p = SK.Cells(EURUSD, 4)
    s = SK.Cells(GBPUSD, 4)
    End If
    
    SR.Cells(SATIR, 1) = X
    SR.Cells(SATIR, 6) = SK.Cells(EURO, q1)
    SR.Cells(SATIR, 7) = SK.Cells(EURO, q2)
    SR.Cells(SATIR, 8) = SK.Cells(EURO, q3)
    SR.Cells(SATIR, 9) = SK.Cells(EURO, q4)
    SR.Cells(SATIR, 2) = SK.Cells(USD, q1)
    SR.Cells(SATIR, 3) = SK.Cells(USD, q2)
    SR.Cells(SATIR, 4) = SK.Cells(USD, q3)
    SR.Cells(SATIR, 5) = SK.Cells(USD, q4)
    SR.Cells(SATIR, 10) = SK.Cells(GBP, q1)
    SR.Cells(SATIR, 11) = SK.Cells(GBP, q2)
    SR.Cells(SATIR, 12) = SK.Cells(GBP, q3)
    SR.Cells(SATIR, 13) = SK.Cells(GBP, q4)
    SR.Cells(SATIR, 14) = p
    SR.Cells(SATIR, 15) = s
    End If
  '**********************************************
    DoEvents
    
    Next
devam:
    Next
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    With Application
    .DecimalSeparator = ","
    .ThousandsSeparator = "."
    .UseSystemSeparators = False
    End With
    
    [A1].Select
    Application.ScreenUpdating = True
    Unload BEKLEME
    MsgBox "İŞLEMİNİZ BAŞARIYLA TAMAMLANMIŞTIR.", vbInformation
End Sub

Sub TCMB()
    On Error GoTo Hata
    Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus
    Exit Sub
Hata:
    MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
    & Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
End Sub
n...
 

catalinastrap

Destek Ekibi
Destek Ekibi
Katılım
19 Ağustos 2006
Mesajlar
491
Beğeniler
2
Excel Vers. ve Dili
Office 2010 / Türkçe
#2
Sub SORGULA()
Application.ScreenUpdating = False
Set SR = Sheets("RAPOR")
SR.Select
If [B1] = "" Then MsgBox "LÜTFEN İLK TARİHİ GİRİNİZ !", vbExclamation, "DİKKAT !": [B1].Select: Exit Sub
If [B2] = "" Then MsgBox "LÜTFEN SON TARİHİ GİRİNİZ !", vbExclamation, "DİKKAT !": [B2].Select: Exit Sub
If [B2] < [B1] Then
MsgBox "SON TARİH İLK TARİHTEN KÜÇÜK OLAMAZ !" _
& Chr(10) & Chr(10) & "LÜTFEN GİRDİĞİNİZ BİLGİLERİ KONTROL EDİNİZ.", vbCritical, "DİKKAT !"
[B2].ClearContents
[B2].Select
Exit Sub
End If

[A6:O65536].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

For X = SR.[B1] To SR.[B2]
If X > Date Then Exit For
KONTROL = Weekday(X, vbMonday)
If KONTROL > 5 Then
y = X - (KONTROL - 5)
Else
y = X
End If

On Error Resume Next

URL1 = "URL;https://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/TRY", LookAt:=xlPart).Row
USD = SK.[A:A].Find(What:="USD/TRY", LookAt:=xlPart).Row
GBP = SK.[A:A].Find(What:="GBP/TRY", LookAt:=xlPart).Row
EURUSD = SK.[A:A].Find(What:="EUR/USD", LookAt:=xlPart).Row
GBPUSD = SK.[A:A].Find(What:="GBP/USD", LookAt:=xlPart).Row

If y < 39925 And y > 40276 Then
q1 = 3: q2 = 4: q3 = 5: q4 = 6

Dim j, k, p, s, l()
p = "": k = Len(SK.Cells(EURUSD, 3))
ReDim l(k)
For j = 1 To k
l(j) = Mid(SK.Cells(EURUSD, 3), j, 1)
If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
l(j) = l(j)
Else
l(j) = ""
End If

If l(j) = "," Then
l(j) = "."
End If

p = p & l(j)
Next

s = "": k = Len(SK.Cells(GBPUSD, 3))
ReDim l(k)
For j = 1 To k
l(j) = Mid(SK.Cells(GBPUSD, 3), j, 1)
If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
l(j) = l(j)
Else
l(j) = ""
End If

If l(j) = "," Then
l(j) = "."
End If

s = s & l(j)
Next

Else
q1 = 4: q2 = 5: q3 = 6: q4 = 7
p = SK.Cells(EURUSD, 4)
s = SK.Cells(GBPUSD, 4)
End If

SR.Cells(SATIR, 1) = X
SR.Cells(SATIR, 2) = SK.Cells(USD, q1)
SR.Cells(SATIR, 3) = SK.Cells(USD, q2)
SR.Cells(SATIR, 4) = SK.Cells(USD, q3)
SR.Cells(SATIR, 5) = SK.Cells(USD, q4)
SR.Cells(SATIR, 6) = SK.Cells(EURO, q1)
SR.Cells(SATIR, 7) = SK.Cells(EURO, q2)
SR.Cells(SATIR, 8) = SK.Cells(EURO, q3)
SR.Cells(SATIR, 9) = SK.Cells(EURO, q4)
SR.Cells(SATIR, 10) = SK.Cells(GBP, q1)
SR.Cells(SATIR, 11) = SK.Cells(GBP, q2)
SR.Cells(SATIR, 12) = SK.Cells(GBP, q3)
SR.Cells(SATIR, 13) = SK.Cells(GBP, q4)
SR.Cells(SATIR, 14) = p
SR.Cells(SATIR, 15) = s
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;https://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/TRY", LookAt:=xlPart).Row
USD = SK.[A:A].Find(What:="USD/TRY", LookAt:=xlPart).Row
GBP = SK.[A:A].Find(What:="GBP/TRY", LookAt:=xlPart).Row
EURUSD = SK.[A:A].Find(What:="EUR/USD", LookAt:=xlPart).Row
GBPUSD = SK.[A:A].Find(What:="GBP/USD", LookAt:=xlPart).Row

If y < 39925 Or y > 40276 Then
q1 = 3: q2 = 4: q3 = 5: q4 = 6

'Dim j, k, p, s, l()
p = "": k = Len(SK.Cells(EURUSD, 3))
ReDim l(k)
For j = 1 To k
l(j) = Mid(SK.Cells(EURUSD, 3), j, 1)
If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
l(j) = l(j)
Else
l(j) = ""
End If

If l(j) = "," Then
l(j) = "."
End If

p = p & l(j)
Next

s = "": k = Len(SK.Cells(GBPUSD, 3))
ReDim l(k)
For j = 1 To k
l(j) = Mid(SK.Cells(GBPUSD, 3), j, 1)
If l(j) = "0" Or l(j) = "1" Or l(j) = "2" Or l(j) = "3" Or l(j) = "4" Or l(j) = "5" Or l(j) = "6" Or l(j) = "7" Or l(j) = "8" Or l(j) = "9" Or l(j) = "." Or l(j) = "," Then
l(j) = l(j)
Else
l(j) = ""
End If

If l(j) = "," Then
l(j) = "."
End If

s = s & l(j)
Next

Else
q1 = 4: q2 = 5: q3 = 6: q4 = 7
p = SK.Cells(EURUSD, 4)
s = SK.Cells(GBPUSD, 4)
End If

SR.Cells(SATIR, 1) = X
SR.Cells(SATIR, 6) = SK.Cells(EURO, q1)
SR.Cells(SATIR, 7) = SK.Cells(EURO, q2)
SR.Cells(SATIR, 8) = SK.Cells(EURO, q3)
SR.Cells(SATIR, 9) = SK.Cells(EURO, q4)
SR.Cells(SATIR, 2) = SK.Cells(USD, q1)
SR.Cells(SATIR, 3) = SK.Cells(USD, q2)
SR.Cells(SATIR, 4) = SK.Cells(USD, q3)
SR.Cells(SATIR, 5) = SK.Cells(USD, q4)
SR.Cells(SATIR, 10) = SK.Cells(GBP, q1)
SR.Cells(SATIR, 11) = SK.Cells(GBP, q2)
SR.Cells(SATIR, 12) = SK.Cells(GBP, q3)
SR.Cells(SATIR, 13) = SK.Cells(GBP, q4)
SR.Cells(SATIR, 14) = p
SR.Cells(SATIR, 15) = s
End If
'**********************************************
DoEvents

Next
devam:
Next

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

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

[A1].Select
Application.ScreenUpdating = True
Unload BEKLEME
MsgBox "İŞLEMİNİZ BAŞARIYLA TAMAMLANMIŞTIR.", vbInformation
End Sub

Sub TCMB()
On Error GoTo Hata
Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & "https://www.tcmb.gov.tr", vbMaximizedFocus
Exit Sub
Hata:
MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
& Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
End Sub
 
Üst