• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

  • Konbuyu başlatan Konbuyu başlatan halit3
  • Başlangıç tarihi Başlangıç tarihi
Bende internet explorer 11 var, versiyonla alakalı olabilir mi?
 
TCMB döviz kurları

halit3' Alıntı:
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.
Genişletmek için tıkla ...

Üstad foruma dosyayı nasıl ekleyeceğimi bilemediğim için size göndermek istiyorum demiştim ve nasıl olacağını da öğrenmiş oldum. dosyamı yükledim yardımcı olursanız sevinirim, şimdiden teşekkürler, saygılar

http://s3.dosya.tc/server28/meU5fY/KURLAR.rar.html
 
alperentug' Alıntı:
Üstad foruma dosyayı nasıl ekleyeceğimi bilemediğim için size göndermek istiyorum demiştim ve nasıl olacağını da öğrenmiş oldum. dosyamı yükledim yardımcı olursanız sevinirim, şimdiden teşekkürler, saygılar

http://s3.dosya.tc/server28/meU5fY/KURLAR.rar.html
Genişletmek için tıkla ...

Sizin göndermiş olduğunuz dosyada kurlar dış verial yöntemi ile kurları olmaktadır benim yazdığım kodlar makro yöntemi ile kurları almaktadır.

Webden Bilgi Sorgulama bölümüne bakarsanız sizin dosyanıza benzer uygulamalar var.

Aşağıdaki linkdeki dosyalar yaklaşık buna benzer kurları getirmektedir.

http://www.excel.web.tr/f125/doviz-kurlary-webden-sorgulama-t105168.html

sizin dosyanızın bir benzeri aşağıdaki linkde mevcut sorularınızı oradan sora bilirsiniz.

http://www.excel.web.tr/f14/doviz-kuru-t71148.html
 
alperentug' Alıntı:
Üstad foruma dosyayı nasıl ekleyeceğimi bilemediğim için size göndermek istiyorum demiştim ve nasıl olacağını da öğrenmiş oldum. dosyamı yükledim yardımcı olursanız sevinirim, şimdiden teşekkürler, saygılar

http://s3.dosya.tc/server28/meU5fY/KURLAR.rar.html
Genişletmek için tıkla ...

Aslında ben başkalarının yazdığı kodlara müdahale etmiyorum.
Dosyana yeniden baktım kodu yazan ben değilim ancak küçük değişikliklerle işlem yapılabilir.

kod:

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, SK As Worksheet
    Dim BUL As Range, TARİH As Date, YENİ_TARİH As Date
    Dim SAYFA_ADI As String, Kontrol As Boolean, ONAY As String
    Dim URL_LINK As String, SAY As Byte, SÜTUN As Integer
    Dim USD_BUL As Range, USD_SATIR As Long, USD_SÜTUN As Byte
    Dim EURO_BUL As Range, EURO_SATIR As Long, EURO_SÜTUN As Byte
    Dim GBP_BUL As Range, GBP_SATIR As Long, GBP_SÜTUN As Byte

    If Intersect(Target, [A4:A3000]) Is Nothing Then Exit Sub
    If Target.Rows.Count = 1 And Target.Count > 1 Then Exit Sub
    
    If Target.Rows.Count > 1 And WorksheetFunction.CountIf(Range(Selection.Resize(Selection.Rows.Count, 1).Address), "") = Target.Rows.Count Then
        Range("B" & Selection.Row, "N" & Selection.Row + Selection.Rows.Count - 1).ClearContents
        Exit Sub
    End If
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If IsDate(Target) = False And Target <> "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        MsgBox "Lütfen tarih giriniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target = "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Not IsNumeric(CLng(Target)) Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Year(Target) < 1900 Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target > Date Then
        MsgBox "Bugünden büyük bir tarihi sorgulayamazsınız !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If (CheckInternetConnection = False) Then
        MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
        & Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    Set S1 = Sheets("KURLAR")
    Set S2 = Sheets("RESMİ_TATİLLER")
    TARİH = Target - 1
    SAYFA_ADI = "DÖVİZ_KURLARI"
    
    Application.ScreenUpdating = False
        
    Range("B" & Target.Row & ":N" & Target.Row).ClearContents
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DÖVİZ_KURLARI").Delete
    Application.DisplayAlerts = True
    
    Sheets.Add , After:=Sheets(Worksheets.Count)
    ActiveSheet.Name = SAYFA_ADI
    Set SK = Sheets(SAYFA_ADI)
    S1.Select
    
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    

Başla:
    
    Set BUL = S2.Range("C:C").Find(TARİH, LookAt:=xlWhole)
    Kontrol = False
    
    If Weekday(TARİH, vbMonday) = 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 And Not BUL Is Nothing Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) < 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 6 Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    End If
    
    TARİH = IIf(YENİ_TARİH = "00:00:00", TARİH, YENİ_TARİH)
    
    If Kontrol = True Then GoTo Başla
    
    If (Time < "08:00:00" Or Time >= "15:30:00") And TARİH = Date And Weekday(TARİH, vbMonday) < 6 Then
        ONAY = MsgBox("Şuanda Saat " & TimeSerial(Hour(Now()), Minute(Now()), Second(Now())) _
        & vbCrLf & vbCrLf & "Dün yayımlanmış resmi kurlar alınacaktır !" _
        & vbCrLf & "Devam etmek istiyor musunuz ?", vbExclamation + vbYesNo, "Dikkat !")
        
        If ONAY = vbYes Then
            TARİH = TARİH - 1
        Else
            GoTo Son
        End If
    End If
    
    
    Application.EnableEvents = False
    Target.Offset(0, 1) = TARİH
    Application.EnableEvents = True
    
    On Error GoTo Hata
    
    URL_LINK = "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) [COLOR="Red"]& ".xml"[/COLOR] '& ".html"

    With SK.QueryTables.Add(Connection:=URL_LINK, Destination:=SK.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
    
    If SK.[A1] <> "" Then
    
        Set USD_BUL = SK.[A:A].Find(What:="USD", LookAt:=xlPart)
        If Not USD_BUL Is Nothing Then
        USD_SATIR = USD_BUL.Row
        [COLOR="red"]USD_SÜTUN = 4[/COLOR]
        
        For SÜTUN = 1 To 256
            SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
            If IsNumeric(Right(SK.Cells(USD_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
              [COLOR="red"]  'USD_SÜTUN = SÜTUN[/COLOR]
                Exit For
            End If
        Next
        End If
        
        
        Set EURO_BUL = SK.[A:A].Find(What:="EUR", LookAt:=xlPart)
        If Not EURO_BUL Is Nothing Then
        EURO_SATIR = EURO_BUL.Row
       [COLOR="red"] EURO_SÜTUN = 4[/COLOR]
        
        For SÜTUN = 1 To 256
            SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
            If IsNumeric(Right(SK.Cells(EURO_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
         [COLOR="red"]      ' EURO_SÜTUN = SÜTUN[/COLOR]
                Exit For
            End If
        Next
        End If
        
        
        Set GBP_BUL = SK.[A:A].Find(What:="GBP", LookAt:=xlPart)
        If Not GBP_BUL Is Nothing Then
        GBP_SATIR = GBP_BUL.Row
      [COLOR="red"]  GBP_SÜTUN = 4[/COLOR]
        
        For SÜTUN = 1 To 256
            SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
            If IsNumeric(Right(SK.Cells(GBP_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
        [COLOR="red"]        'GBP_SÜTUN = SÜTUN[/COLOR]
                Exit For
            End If
        Next
        End If
        
        S1.Cells(Target.Row, "C") = SK.Cells(USD_SATIR, USD_SÜTUN)
        S1.Cells(Target.Row, "D") = SK.Cells(USD_SATIR, USD_SÜTUN + 1)
        S1.Cells(Target.Row, "E") = SK.Cells(USD_SATIR, USD_SÜTUN + 2)
        S1.Cells(Target.Row, "F") = SK.Cells(USD_SATIR, USD_SÜTUN + 3)
        S1.Cells(Target.Row, "G") = SK.Cells(EURO_SATIR, EURO_SÜTUN)
        S1.Cells(Target.Row, "H") = SK.Cells(EURO_SATIR, EURO_SÜTUN + 1)
        S1.Cells(Target.Row, "I") = SK.Cells(EURO_SATIR, EURO_SÜTUN + 2)
        S1.Cells(Target.Row, "J") = SK.Cells(EURO_SATIR, EURO_SÜTUN + 3)
        S1.Cells(Target.Row, "K") = SK.Cells(GBP_SATIR, GBP_SÜTUN)
        S1.Cells(Target.Row, "L") = SK.Cells(GBP_SATIR, GBP_SÜTUN + 1)
        S1.Cells(Target.Row, "M") = SK.Cells(GBP_SATIR, GBP_SÜTUN + 2)
        S1.Cells(Target.Row, "N") = SK.Cells(GBP_SATIR, GBP_SÜTUN + 3)
    
    End If
        
    Application.DisplayAlerts = False
   SK.Delete
    Application.DisplayAlerts = True
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    Application.ScreenUpdating = True
    Exit Sub

Hata:
    S1.Cells(Target.Row, "C") = "Hata !"
    S1.Cells(Target.Row, "D") = "Hata !"
    S1.Cells(Target.Row, "E") = "Hata !"
    S1.Cells(Target.Row, "F") = "Hata !"
    S1.Cells(Target.Row, "G") = "Hata !"
    S1.Cells(Target.Row, "H") = "Hata !"
    S1.Cells(Target.Row, "I") = "Hata !"
    S1.Cells(Target.Row, "J") = "Hata !"
    S1.Cells(Target.Row, "K") = "Hata !"
    S1.Cells(Target.Row, "L") = "Hata !"
    S1.Cells(Target.Row, "M") = "Hata !"
    S1.Cells(Target.Row, "N") = "Hata !"
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    ONAY = MsgBox(TARİH & " tarihi sorgulanırken web sayfasına bağlantı hatası oluştu !" _
    & vbCrLf & "Lütfen " & "www.tcmb.gov.tr" & " sitesine bağlanıp " & TARİH & " tarihine ait kurları kontrol ediniz !" _
    & vbCrLf & vbCrLf & "Web sayfasına bağlanmak istiyor musunuz ?", vbCritical + vbYesNo, "Dikkat !")
        
    If ONAY = vbYes Then
  
   [COLOR="red"] 'Shell "e:\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus
    Dim sec
    sec = Mid(CreateObject("wscript.Shell").SpecialFolders.Item("Desktop"), 1, 1)
    Shell sec & ":\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus[/COLOR]
        
        Exit Sub
    Else
        Exit Sub
    End If

Son:
    Target.ClearContents
    Target.Select
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz iptal edilmiştir !", vbExclamation
End Sub

yada bu kodu deneyiniz.


Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, SK As Worksheet
    Dim BUL As Range, TARİH As Date, YENİ_TARİH As Date
    Dim SAYFA_ADI As String, Kontrol As Boolean, ONAY As String
    Dim URL_LINK As String, SAY As Byte, SÜTUN As Integer

    If Intersect(Target, [A4:A3000]) Is Nothing Then Exit Sub
    If Target.Rows.Count = 1 And Target.Count > 1 Then Exit Sub
    
    If Target.Rows.Count > 1 And WorksheetFunction.CountIf(Range(Selection.Resize(Selection.Rows.Count, 1).Address), "") = Target.Rows.Count Then
        Range("B" & Selection.Row, "N" & Selection.Row + Selection.Rows.Count - 1).ClearContents
        Exit Sub
    End If
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If IsDate(Target) = False And Target <> "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        MsgBox "Lütfen tarih giriniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target = "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Not IsNumeric(CLng(Target)) Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Year(Target) < 1900 Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target > Date Then
        MsgBox "Bugünden büyük bir tarihi sorgulayamazsınız !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If (CheckInternetConnection = False) Then
        MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
        & Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    Set S1 = Sheets("KURLAR")
    Set S2 = Sheets("RESMİ_TATİLLER")
    TARİH = Target - 1
    SAYFA_ADI = "DÖVİZ_KURLARI"
    
    Application.ScreenUpdating = False
        
    Range("B" & Target.Row & ":N" & Target.Row).ClearContents
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DÖVİZ_KURLARI").Delete
    Application.DisplayAlerts = True
    
    Sheets.Add , After:=Sheets(Worksheets.Count)
    ActiveSheet.Name = SAYFA_ADI
    Set SK = Sheets(SAYFA_ADI)
    S1.Select
    
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    

Başla:
    
    Set BUL = S2.Range("C:C").Find(TARİH, LookAt:=xlWhole)
    Kontrol = False
    
    If Weekday(TARİH, vbMonday) = 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 And Not BUL Is Nothing Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) < 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 6 Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    End If
    
    TARİH = IIf(YENİ_TARİH = "00:00:00", TARİH, YENİ_TARİH)
    
    If Kontrol = True Then GoTo Başla
    
    If (Time < "08:00:00" Or Time >= "15:30:00") And TARİH = Date And Weekday(TARİH, vbMonday) < 6 Then
        ONAY = MsgBox("Şuanda Saat " & TimeSerial(Hour(Now()), Minute(Now()), Second(Now())) _
        & vbCrLf & vbCrLf & "Dün yayımlanmış resmi kurlar alınacaktır !" _
        & vbCrLf & "Devam etmek istiyor musunuz ?", vbExclamation + vbYesNo, "Dikkat !")
        
        If ONAY = vbYes Then
            TARİH = TARİH - 1
        Else
            GoTo Son
        End If
    End If
    
    
    Application.EnableEvents = False
    Target.Offset(0, 1) = TARİH
    Application.EnableEvents = True
    
    On Error GoTo Hata
    
    URL_LINK = "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) & ".xml"
    With SK.QueryTables.Add(Connection:=URL_LINK, Destination:=SK.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
    
    If SK.[A1] <> "" Then
    Dim ekle
    ekle = [COLOR="Red"]3 [/COLOR] 'eklemeleri buradaki sayıyı arttırarak yapabilirsiniz.
    
    ReDim BUL1(ekle)
    Dim s, t, n, sut2
    sut2 = 3
    
    BUL1(1) = "USD/TRY"
    BUL1(2) = "EUR/TRY"
    BUL1(3) = "GBP/TRY"
    
    'BUL1([COLOR="red"]4[/COLOR]) = "JPY/TRY"  'eklemeleri buradaki gibi arttırarak yapabilirsiniz.
    
    For n = 1 To ekle
    
    For s = 1 To SK.Cells(Rows.Count, "A").End(3).Row
    If Trim(SK.Cells(s, 1)) = BUL1(n) Then
    For t = 0 To 3
    S1.Cells(Target.Row, sut2 + t) = SK.Cells(s, 4 + t)
    Next t
    sut2 = sut2 + 4
    End If
    Next s
    
    Next n
    
    End If
        
    Application.DisplayAlerts = False
   SK.Delete
    Application.DisplayAlerts = True
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    Application.ScreenUpdating = True
    Exit Sub

Hata:

Dim k
For k = 3 To S1.Cells(3, Columns.Count).End(xlToLeft).Column
S1.Cells(Target.Row, k) = "Hata !"
Next k
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    ONAY = MsgBox(TARİH & " tarihi sorgulanırken web sayfasına bağlantı hatası oluştu !" _
    & vbCrLf & "Lütfen " & "www.tcmb.gov.tr" & " sitesine bağlanıp " & TARİH & " tarihine ait kurları kontrol ediniz !" _
    & vbCrLf & vbCrLf & "Web sayfasına bağlanmak istiyor musunuz ?", vbCritical + vbYesNo, "Dikkat !")
        
    If ONAY = vbYes Then
    Dim sec
    sec = Mid(CreateObject("wscript.Shell").SpecialFolders.Item("Desktop"), 1, 1)
    Shell sec & ":\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus
        
        Exit Sub
    Else
        Exit Sub
    End If

Son:
    Target.ClearContents
    Target.Select
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz iptal edilmiştir !", vbExclamation
End Sub
 
TCMB Döviz Kurları

halit3' Alıntı:
Dosyana yeniden baktım kodu yazan ben değilim anacak küçük değişikliklerle işlem yapılabilir.
Aslında ben başkalarının yazdığı kodlara müdahale etmiyorum.

kod:

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, SK As Worksheet
    Dim BUL As Range, TARİH As Date, YENİ_TARİH As Date
    Dim SAYFA_ADI As String, Kontrol As Boolean, ONAY As String
    Dim URL_LINK As String, SAY As Byte, SÜTUN As Integer
    Dim USD_BUL As Range, USD_SATIR As Long, USD_SÜTUN As Byte
    Dim EURO_BUL As Range, EURO_SATIR As Long, EURO_SÜTUN As Byte
    Dim GBP_BUL As Range, GBP_SATIR As Long, GBP_SÜTUN As Byte

    If Intersect(Target, [A4:A3000]) Is Nothing Then Exit Sub
    If Target.Rows.Count = 1 And Target.Count > 1 Then Exit Sub
    
    If Target.Rows.Count > 1 And WorksheetFunction.CountIf(Range(Selection.Resize(Selection.Rows.Count, 1).Address), "") = Target.Rows.Count Then
        Range("B" & Selection.Row, "N" & Selection.Row + Selection.Rows.Count - 1).ClearContents
        Exit Sub
    End If
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If IsDate(Target) = False And Target <> "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        MsgBox "Lütfen tarih giriniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target = "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Not IsNumeric(CLng(Target)) Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Year(Target) < 1900 Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target > Date Then
        MsgBox "Bugünden büyük bir tarihi sorgulayamazsınız !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If (CheckInternetConnection = False) Then
        MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
        & Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    Set S1 = Sheets("KURLAR")
    Set S2 = Sheets("RESMİ_TATİLLER")
    TARİH = Target - 1
    SAYFA_ADI = "DÖVİZ_KURLARI"
    
    Application.ScreenUpdating = False
        
    Range("B" & Target.Row & ":N" & Target.Row).ClearContents
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DÖVİZ_KURLARI").Delete
    Application.DisplayAlerts = True
    
    Sheets.Add , After:=Sheets(Worksheets.Count)
    ActiveSheet.Name = SAYFA_ADI
    Set SK = Sheets(SAYFA_ADI)
    S1.Select
    
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    

Başla:
    
    Set BUL = S2.Range("C:C").Find(TARİH, LookAt:=xlWhole)
    Kontrol = False
    
    If Weekday(TARİH, vbMonday) = 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 And Not BUL Is Nothing Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) < 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 6 Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    End If
    
    TARİH = IIf(YENİ_TARİH = "00:00:00", TARİH, YENİ_TARİH)
    
    If Kontrol = True Then GoTo Başla
    
    If (Time < "08:00:00" Or Time >= "15:30:00") And TARİH = Date And Weekday(TARİH, vbMonday) < 6 Then
        ONAY = MsgBox("Şuanda Saat " & TimeSerial(Hour(Now()), Minute(Now()), Second(Now())) _
        & vbCrLf & vbCrLf & "Dün yayımlanmış resmi kurlar alınacaktır !" _
        & vbCrLf & "Devam etmek istiyor musunuz ?", vbExclamation + vbYesNo, "Dikkat !")
        
        If ONAY = vbYes Then
            TARİH = TARİH - 1
        Else
            GoTo Son
        End If
    End If
    
    
    Application.EnableEvents = False
    Target.Offset(0, 1) = TARİH
    Application.EnableEvents = True
    
    On Error GoTo Hata
    
    URL_LINK = "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) [COLOR="Red"]& ".xml"[/COLOR] '& ".html"

    With SK.QueryTables.Add(Connection:=URL_LINK, Destination:=SK.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
    
    If SK.[A1] <> "" Then
    
        Set USD_BUL = SK.[A:A].Find(What:="USD", LookAt:=xlPart)
        If Not USD_BUL Is Nothing Then
        USD_SATIR = USD_BUL.Row
        [COLOR="red"]USD_SÜTUN = 4[/COLOR]
        
        For SÜTUN = 1 To 256
            SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
            If IsNumeric(Right(SK.Cells(USD_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
              [COLOR="red"]  'USD_SÜTUN = SÜTUN[/COLOR]
                Exit For
            End If
        Next
        End If
        
        
        Set EURO_BUL = SK.[A:A].Find(What:="EUR", LookAt:=xlPart)
        If Not EURO_BUL Is Nothing Then
        EURO_SATIR = EURO_BUL.Row
       [COLOR="red"] EURO_SÜTUN = 4[/COLOR]
        
        For SÜTUN = 1 To 256
            SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
            If IsNumeric(Right(SK.Cells(EURO_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
         [COLOR="red"]      ' EURO_SÜTUN = SÜTUN[/COLOR]
                Exit For
            End If
        Next
        End If
        
        
        Set GBP_BUL = SK.[A:A].Find(What:="GBP", LookAt:=xlPart)
        If Not GBP_BUL Is Nothing Then
        GBP_SATIR = GBP_BUL.Row
      [COLOR="red"]  GBP_SÜTUN = 4[/COLOR]
        
        For SÜTUN = 1 To 256
            SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
            If IsNumeric(Right(SK.Cells(GBP_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
        [COLOR="red"]        'GBP_SÜTUN = SÜTUN[/COLOR]
                Exit For
            End If
        Next
        End If
        
        S1.Cells(Target.Row, "C") = SK.Cells(USD_SATIR, USD_SÜTUN)
        S1.Cells(Target.Row, "D") = SK.Cells(USD_SATIR, USD_SÜTUN + 1)
        S1.Cells(Target.Row, "E") = SK.Cells(USD_SATIR, USD_SÜTUN + 2)
        S1.Cells(Target.Row, "F") = SK.Cells(USD_SATIR, USD_SÜTUN + 3)
        S1.Cells(Target.Row, "G") = SK.Cells(EURO_SATIR, EURO_SÜTUN)
        S1.Cells(Target.Row, "H") = SK.Cells(EURO_SATIR, EURO_SÜTUN + 1)
        S1.Cells(Target.Row, "I") = SK.Cells(EURO_SATIR, EURO_SÜTUN + 2)
        S1.Cells(Target.Row, "J") = SK.Cells(EURO_SATIR, EURO_SÜTUN + 3)
        S1.Cells(Target.Row, "K") = SK.Cells(GBP_SATIR, GBP_SÜTUN)
        S1.Cells(Target.Row, "L") = SK.Cells(GBP_SATIR, GBP_SÜTUN + 1)
        S1.Cells(Target.Row, "M") = SK.Cells(GBP_SATIR, GBP_SÜTUN + 2)
        S1.Cells(Target.Row, "N") = SK.Cells(GBP_SATIR, GBP_SÜTUN + 3)
    
    End If
        
    Application.DisplayAlerts = False
   SK.Delete
    Application.DisplayAlerts = True
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    Application.ScreenUpdating = True
    Exit Sub

Hata:
    S1.Cells(Target.Row, "C") = "Hata !"
    S1.Cells(Target.Row, "D") = "Hata !"
    S1.Cells(Target.Row, "E") = "Hata !"
    S1.Cells(Target.Row, "F") = "Hata !"
    S1.Cells(Target.Row, "G") = "Hata !"
    S1.Cells(Target.Row, "H") = "Hata !"
    S1.Cells(Target.Row, "I") = "Hata !"
    S1.Cells(Target.Row, "J") = "Hata !"
    S1.Cells(Target.Row, "K") = "Hata !"
    S1.Cells(Target.Row, "L") = "Hata !"
    S1.Cells(Target.Row, "M") = "Hata !"
    S1.Cells(Target.Row, "N") = "Hata !"
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    ONAY = MsgBox(TARİH & " tarihi sorgulanırken web sayfasına bağlantı hatası oluştu !" _
    & vbCrLf & "Lütfen " & "www.tcmb.gov.tr" & " sitesine bağlanıp " & TARİH & " tarihine ait kurları kontrol ediniz !" _
    & vbCrLf & vbCrLf & "Web sayfasına bağlanmak istiyor musunuz ?", vbCritical + vbYesNo, "Dikkat !")
        
    If ONAY = vbYes Then
  
   [COLOR="red"] 'Shell "e:\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus
    Dim sec
    sec = Mid(CreateObject("wscript.Shell").SpecialFolders.Item("Desktop"), 1, 1)
    Shell sec & ":\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus[/COLOR]
        
        Exit Sub
    Else
        Exit Sub
    End If

Son:
    Target.ClearContents
    Target.Select
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz iptal edilmiştir !", vbExclamation
End Sub

yada bu kodu deneyiniz.


Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, SK As Worksheet
    Dim BUL As Range, TARİH As Date, YENİ_TARİH As Date
    Dim SAYFA_ADI As String, Kontrol As Boolean, ONAY As String
    Dim URL_LINK As String, SAY As Byte, SÜTUN As Integer

    If Intersect(Target, [A4:A3000]) Is Nothing Then Exit Sub
    If Target.Rows.Count = 1 And Target.Count > 1 Then Exit Sub
    
    If Target.Rows.Count > 1 And WorksheetFunction.CountIf(Range(Selection.Resize(Selection.Rows.Count, 1).Address), "") = Target.Rows.Count Then
        Range("B" & Selection.Row, "N" & Selection.Row + Selection.Rows.Count - 1).ClearContents
        Exit Sub
    End If
    
    If Target.Cells.Count > 1 Then Exit Sub
    
    If IsDate(Target) = False And Target <> "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        MsgBox "Lütfen tarih giriniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target = "" Then
        Range("B" & Target.Row, "N" & Target.Row).ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Not IsNumeric(CLng(Target)) Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Year(Target) < 1900 Then
        MsgBox "Hatalı tarih girişi !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Target > Date Then
        MsgBox "Bugünden büyük bir tarihi sorgulayamazsınız !" & vbCrLf & _
        "Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If (CheckInternetConnection = False) Then
        MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
        & Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
        Range("B" & Target.Row & ":N" & Target.Row).ClearContents
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
    
    Set S1 = Sheets("KURLAR")
    Set S2 = Sheets("RESMİ_TATİLLER")
    TARİH = Target - 1
    SAYFA_ADI = "DÖVİZ_KURLARI"
    
    Application.ScreenUpdating = False
        
    Range("B" & Target.Row & ":N" & Target.Row).ClearContents
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DÖVİZ_KURLARI").Delete
    Application.DisplayAlerts = True
    
    Sheets.Add , After:=Sheets(Worksheets.Count)
    ActiveSheet.Name = SAYFA_ADI
    Set SK = Sheets(SAYFA_ADI)
    S1.Select
    
    With Application
        .DecimalSeparator = "."
        .ThousandsSeparator = ","
        .UseSystemSeparators = False
    End With
    

Başla:
    
    Set BUL = S2.Range("C:C").Find(TARİH, LookAt:=xlWhole)
    Kontrol = False
    
    If Weekday(TARİH, vbMonday) = 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 And Not BUL Is Nothing Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) < 6 And Not BUL Is Nothing Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih resmi tatildir." _
        & vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 6 Then
        TARİH = TARİH - 1
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    
    ElseIf Weekday(TARİH, vbMonday) = 7 Then
        TARİH = TARİH - 2
        MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
        & vbCrLf & vbCrLf & TARİH & "  gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
        Kontrol = True
    End If
    
    TARİH = IIf(YENİ_TARİH = "00:00:00", TARİH, YENİ_TARİH)
    
    If Kontrol = True Then GoTo Başla
    
    If (Time < "08:00:00" Or Time >= "15:30:00") And TARİH = Date And Weekday(TARİH, vbMonday) < 6 Then
        ONAY = MsgBox("Şuanda Saat " & TimeSerial(Hour(Now()), Minute(Now()), Second(Now())) _
        & vbCrLf & vbCrLf & "Dün yayımlanmış resmi kurlar alınacaktır !" _
        & vbCrLf & "Devam etmek istiyor musunuz ?", vbExclamation + vbYesNo, "Dikkat !")
        
        If ONAY = vbYes Then
            TARİH = TARİH - 1
        Else
            GoTo Son
        End If
    End If
    
    
    Application.EnableEvents = False
    Target.Offset(0, 1) = TARİH
    Application.EnableEvents = True
    
    On Error GoTo Hata
    
    URL_LINK = "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) & ".xml"
    With SK.QueryTables.Add(Connection:=URL_LINK, Destination:=SK.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
    
    If SK.[A1] <> "" Then
    Dim ekle
    ekle = [COLOR="Red"]3 [/COLOR] 'eklemeleri buradaki sayıyı arttırarak yapabilirsiniz.
    
    ReDim BUL1(ekle)
    Dim s, t, n, sut2
    sut2 = 3
    
    BUL1(1) = "USD/TRY"
    BUL1(2) = "EUR/TRY"
    BUL1(3) = "GBP/TRY"
    
    'BUL1([COLOR="red"]4[/COLOR]) = "JPY/TRY"  'eklemeleri buradaki gibi arttırarak yapabilirsiniz.
    
    For n = 1 To ekle
    
    For s = 1 To SK.Cells(Rows.Count, "A").End(3).Row
    If Trim(SK.Cells(s, 1)) = BUL1(n) Then
    For t = 0 To 3
    S1.Cells(Target.Row, sut2 + t) = SK.Cells(s, 4 + t)
    Next t
    sut2 = sut2 + 4
    End If
    Next s
    
    Next n
    
    End If
        
    Application.DisplayAlerts = False
   SK.Delete
    Application.DisplayAlerts = True
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    Application.ScreenUpdating = True
    Exit Sub

Hata:

Dim k
For k = 3 To S1.Cells(3, Columns.Count).End(xlToLeft).Column
S1.Cells(Target.Row, k) = "Hata !"
Next k
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    ONAY = MsgBox(TARİH & " tarihi sorgulanırken web sayfasına bağlantı hatası oluştu !" _
    & vbCrLf & "Lütfen " & "www.tcmb.gov.tr" & " sitesine bağlanıp " & TARİH & " tarihine ait kurları kontrol ediniz !" _
    & vbCrLf & vbCrLf & "Web sayfasına bağlanmak istiyor musunuz ?", vbCritical + vbYesNo, "Dikkat !")
        
    If ONAY = vbYes Then
    Dim sec
    sec = Mid(CreateObject("wscript.Shell").SpecialFolders.Item("Desktop"), 1, 1)
    Shell sec & ":\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus
        
        Exit Sub
    Else
        Exit Sub
    End If

Son:
    Target.ClearContents
    Target.Select
    
    With Application
        .DecimalSeparator = ","
        .ThousandsSeparator = "."
        .UseSystemSeparators = False
    End With
    
    Application.DisplayAlerts = False
    SK.Delete
    Application.DisplayAlerts = True
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set SK = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz iptal edilmiştir !", vbExclamation
End Sub
Genişletmek için tıkla ...


Halit3 Üstadım çok teşekkürler, emeğinize ve ellerinize sağlık. Allaha emanet olunuz.
 
1 nolu mesajdaki dosya güncellendi
 
Acaba bu program daha da genişletilebilir mi? Mesela ihracat yapan firmalarda beyannameye rakam atmak için ilgili GÇB'nin gümrük beyanname sorgulama sayfasında kapanışının sorgulanması gerekiyor sonra da bu kapanış tarihine göre GÇB üzerindeki döviz kurunun ilgili kapanış tarihindeki merkez bankası döviz kuru ile çarpılıp sonucunun alınması biraz fazla ütobik oldu sanırım ama yapılabilirse muazzam olur diye düşünüyorum .

Yani örnek listeye bir makro yapılabilirse o verileri internetten çekme gibi bir durum olabilir mi
 

Ekli dosyalar

Bu proğram ile sizin dosya çok farklı şeyler siz en iyisi farklı bir konu başlığı altında yeni soru sorarak sorunuzu sorun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst