TCMB Döviz Alış Kuru Sorunu

elevisse · 4 Mayıs 2009

Arkadaşlar, Merkez Bankasından döviz alış kurlarını alırken hata ile karşılaşıyorum. Sanırım sayfa yapısındaki değişiklikten kaynaklanmakta bu sorun. Korhan Bey'in büyük katkılarıyla hazırlamış olduğum Masraf formunda döviz alış kur'u gelmemekte. Konuyla ilgili yardımlarınızı bekliyorum. Ekte Formu bulabilirsiniz. VBA şifresi 12345 dir.Yardımlarınız için şimdiden teşekürler.

Korhan Ayhan · 4 Mayıs 2009

Selamlar,

"MASRAF" isimli sayfanıza ait kodu aşağıdaki şekilde değiştirip denermisiniz.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    Dim GÜN As Byte, AY As Byte, YIL As Integer, TARİH As Date
    Dim KONTROL As Byte, URL1 As String, SAY As Byte, SÜTUN As Integer
    Dim EUR_BUL As Range, EUR_SATIR As Long, EUR_SÜTUN As Byte
    Dim USD_BUL As Range, USD_SATIR As Long, USD_SÜTUN As Byte
    Dim DKK_BUL As Range, DKK_SATIR As Long, DKK_SÜTUN As Byte
    Dim GBP_BUL As Range, GBP_SATIR As Long, GBP_SÜTUN As Byte
    
    Set S1 = Sheets("MASRAF")
    Set S2 = Sheets("Dövizler")
    
    If Intersect(Target, [B14:B65536,I14:I65536]) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect "12345"
    If Target.Count > 1 Then GoTo Çıkış
    If Target = "TRY" Then
    Cells(Target.Row, "J") = 1
    GoTo Çıkış
    End If
    If Cells(Target.Row, "B") = Empty Then
    Cells(Target.Row, "J") = Empty
    Cells(Target.Row, "N") = Empty
    GoTo Çıkış
    End If
    
    With Application
    .DecimalSeparator = "."
    .ThousandsSeparator = ","
    .UseSystemSeparators = False
    End With
    
    GÜN = Format(Day(Cells(Target.Row, "B")), "00")
    AY = Format(Month(Cells(Target.Row, "B")), "00")
    YIL = Format(Year(Cells(Target.Row, "B")), "0000")
    TARİH = DateSerial(YIL, AY, GÜN)
    
    If TARİH > Date Then
    MsgBox "Bugünden sonraki bir tarihi sorgulayamazsınız !" _
    & Chr(10) & Chr(10) & "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "DİKKAT !"
    GoTo Çıkış
    End If
        
    If (Weekday(TARİH, vbMonday) = 6 Or Weekday(TARİH, vbMonday) = 7) Then
   ' MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
    & Chr(10) & Chr(10) & "Önceki iş gününe ait kur bilgileri alınacaktır.", vbExclamation, "DİKKAT !"
    End If
    
    KONTROL = Weekday(TARİH, vbMonday)
    If KONTROL > 5 Then
    TARİH = TARİH - (KONTROL - 5)
    Else
    TARİH = TARİH - 1
    End If
    
    Cells(Target.Row, "N") = TARİH
    
    If (Weekday(TARİH, vbMonday) = 6 Or Weekday(TARİH, vbMonday) = 7) Then
    ' MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
    & Chr(10) & Chr(10) & "Önceki iş gününe ait kur bilgileri alınacaktır.", vbExclamation, "DİKKAT !"
    KONTROL = Weekday(TARİH, vbMonday)
    If KONTROL > 5 Then
    TARİH = TARİH - (KONTROL - 5)
    Else
    TARİH = TARİH - 1
    End If
    Cells(Target.Row, "N") = TARİH
    End If
    
    On Error GoTo Son
    
    URL1 = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(TARİH) & Format(Month(TARİH), "00") & "/" & Format(Day(TARİH), "00") & Format(Month(TARİH), "00") & Year(TARİH) & ".html"
    
    With S2.QueryTables.Add(Connection:=URL1, Destination:=S2.Range("A1"))
        .Name = TARİH
        .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
    
    Set EUR_BUL = S2.[A:A].Find(What:="EUR", LookAt:=xlPart)
    If Not EUR_BUL Is Nothing Then
    EUR_SATIR = EUR_BUL.Row
    
    For SÜTUN = 2 To 256
    SAY = WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "ALIŞ")
    If IsNumeric(Right(S2.Cells(EUR_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
    EUR_SÜTUN = SÜTUN
    Exit For
    End If
    Next
    End If
    
    Set USD_BUL = S2.[A:A].Find(What:="USD", LookAt:=xlPart)
    If Not USD_BUL Is Nothing Then
    USD_SATIR = USD_BUL.Row
    
    For SÜTUN = 2 To 256
    SAY = WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "ALIŞ")
    If IsNumeric(Right(S2.Cells(USD_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
    USD_SÜTUN = SÜTUN
    Exit For
    End If
    Next
    End If
    
    Set DKK_BUL = S2.[A:A].Find(What:="DKK", LookAt:=xlPart)
    If Not DKK_BUL Is Nothing Then
    DKK_SATIR = DKK_BUL.Row
    
    For SÜTUN = 2 To 256
    SAY = WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "ALIŞ")
    If IsNumeric(Right(S2.Cells(DKK_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
    DKK_SÜTUN = SÜTUN
    Exit For
    End If
    Next
    End If
    
    Set GBP_BUL = S2.[A:A].Find(What:="GBP", LookAt:=xlPart)
    If Not GBP_BUL Is Nothing Then
    GBP_SATIR = GBP_BUL.Row
    
    For SÜTUN = 2 To 256
    SAY = WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(S2.Range(S2.Cells(1, SÜTUN), S2.Cells(65536, SÜTUN)), "ALIŞ")
    If IsNumeric(Right(S2.Cells(GBP_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
    GBP_SÜTUN = SÜTUN
    Exit For
    End If
    Next
    End If
    
    Select Case Cells(Target.Row, "I")
    Case Is = "DKK"
    Cells(Target.Row, "J") = S2.Cells(DKK_SATIR, DKK_SÜTUN)
    Case Is = "EUR"
    Cells(Target.Row, "J") = S2.Cells(EUR_SATIR, EUR_SÜTUN)
    Case Is = "GBP"
    Cells(Target.Row, "J") = S2.Cells(GBP_SATIR, GBP_SÜTUN)
    Case Is = "USD"
    Cells(Target.Row, "J") = S2.Cells(USD_SATIR, USD_SÜTUN)
    End Select
    
    With Application
    .UseSystemSeparators = True
    End With
    Beep
    Set S1 = Nothing
    Set S2 = Nothing
    ActiveSheet.Protect "12345"
    Exit Sub
Son:
ActiveSheet.Protect "12345"
MsgBox "İnternet bağlantısı şu anda kurulamıyor !" & vbCrLf & "Lütfen daha sonra tekrar deneyin.", vbCritical, "UYARI !"
Exit Sub
Çıkış:
ActiveSheet.Protect "12345"
Application.ScreenUpdating = True
End Sub

elevisse · 4 Mayıs 2009

Makro

Korhan Bey, öncelikle yardımlarınız için çok teşekürler. Makroyu yazdığınız şekilde değiştirdim ve şuan kuru alabilmekteyim. Çok teşekürler.

kadirafacan · 29 Haziran 2009

elevisse merhaba
dosyanıza yukarıdaki kodları girdim ve çalıştırmayı denedim hata veriyor. son halini bizimle paylaşırmısınız. teşekkürler..

Korhan Ayhan · 29 Haziran 2009

Selamlar,

Sn. kadirafacan,

Dosyanın çalışan halini ektedir. İncelermisiniz.

Makro kodlarının çalışması için ARAÇLAR-MAKRO-GÜVENLİK menüsünden "Orta" seçeneğini seçip tamam dedikten sonra dosyayı tekrar açın.

MASRAF isimli sayfada B sütununda çift tıkladığınızda tarih seçebileceğiniz form açılacaktır. İlgili tarihi seçip çift tıkladığınızda o tarih aktif hücree aktarılacaktır. Daha sonra I sütunundan kur tipini seçtiğinizde kur bilgisi otomatik olarak J sütununa gelecektir.

masuk500 · 13 Ağustos 2009

merhaba sayın korhan ayhan
çok güzel bir çalışma olmuş tarihi seçeceğimiz form olmadan ilgili hücreye tarih yazarak yapamazmıyız? c sütununda tarih k sütununda döviz cinsi ve l sütununda kur olacak şekilde nasıl düzenlenebilir.

Korhan Ayhan · 13 Ağustos 2009

Selamlar,

Sn. masuk500,

Ekteki örnek dosyayı incelermisiniz.

masuk500 · 13 Ağustos 2009

merhaba sayın korhan ayhan
döviz tipi sayfası olmadan döviz tipleri aynı sayfa içinde olabilirmi?
ayrıca birgün öncesinin kurunu alıyor aynı günün kurunu alabilir mi?

edit : kodları istediğim şekilde uyarladım.tek bir sorun kaldı.o da tarih alanına metin girildiğinde hata veriyor.bunu nasıl yapacağımı bulamadım.

Korhan Ayhan · 18 Ağustos 2009

Selamlar,

Üstteki mesajımdaki dosyayı güncelledim. İncelermisiniz.

Döviz tipleri aynı sayfanın "AA" sütunundadır.

Korhan Ayhan · 26 Ağustos 2009

Selamlar,

Arkadaşlar #7 nolu mesajımdaki dosyada bir hata vardı dosya revize edilmiştir. Lütfen son halini kullanınız.

TCMB Döviz Alış Kuru Sorunu

elevisse

Ekli dosyalar

Korhan Ayhan

Administrator

elevisse

kadirafacan

Korhan Ayhan

Administrator

Ekli dosyalar

masuk500

Korhan Ayhan

Administrator

Ekli dosyalar

masuk500

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator