günlük döviz kurlarını almak

masuk500 · 29 Haziran 2017

merhaba arkadaşlar
daha önce sitenizden almış olduğum aşağıdaki kodlar bir süredir tcmb sitesindeki değişikliklerden dolayı çalışmıyor kodlar aşağıdadır yardımlarınızı bekliyorum şimdiden teşekkürler

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("FATURAGİRİŞ")
Set S2 = Sheets("DÖVİZLER")

If Intersect(Target, [C4:C65536,M4:M65536]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
If Target.Count > 1 Then GoTo Çıkış
If Target = "Tl" Then
Cells(Target.Row, "N") = 1
GoTo Çıkış
End If
If Cells(Target.Row, "C") = Empty Then
Cells(Target.Row, "N") = Empty
Cells(Target.Row, "Z") = Empty
GoTo Çıkış
End If

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

GÜN = Format(Day(Cells(Target.Row, "C")), "00")
AY = Format(Month(Cells(Target.Row, "C")), "00")
YIL = Format(Year(Cells(Target.Row, "C")), "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
End If

Cells(Target.Row, "Z") = 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, "Z") = 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, "M")
Case Is = "DKK"
Cells(Target.Row, "N") = S2.Cells(DKK_SATIR, DKK_SÜTUN)
Case Is = "EUR"
Cells(Target.Row, "N") = S2.Cells(EUR_SATIR, EUR_SÜTUN)
Case Is = "GBP"
Cells(Target.Row, "N") = S2.Cells(GBP_SATIR, GBP_SÜTUN)
Case Is = "USD"
Cells(Target.Row, "N") = S2.Cells(USD_SATIR, USD_SÜTUN)
End Select

With Application
.UseSystemSeparators = True
End With

Set S1 = Nothing
Set S2 = Nothing
Exit Sub
Son:
MsgBox "İnternet bağlantısı şu anda kurulamıyor !" & vbCrLf & "Lütfen daha sonra tekrar deneyin.", vbCritical, "UYARI !"
Exit Sub
Çıkış:
Application.ScreenUpdating = True
End Sub

günlük döviz kurlarını almak

masuk500