Merkez bankası parametre ve kur çekme

[S.Yiğit]

Merhaba,

A Sütununa tarih yazdığımda L sütununa merkez bankasından euro usd parametresinin gelmesi gerekiyor. Ayrına M sütununa Euro kuru, N sütununa Usd kuru gelmeli. Örnek tablom ektedir. Ayrıca harici upload sitesinden de yükledim. Yardımcı olacak arkadaşlara şimdiden teşekkürler.


http://s3.dosya.tc/server17/WOjVPQ/Navluntakipsoru.rar.html

 

[soykan]

Merhaba, Aşağıdaki linkden dosyayı indirip inceleyiniz.
Örneğinize 2 sayfa ilave olduğunu göreceksiniz. Sayfa 1 MB kayıtlarının transfer edildiği sayfadır. 2014 de ise her gün transfer butonuna basarsanız MB kayıtlarının depolandığı data sayfasıdır. Daha sonra buradan isteğiniz günleri çekebilirsiniz. Örneğinizi de yaptım.
http://dosya.co/lrsx25fl9mhv/Navlun_Takip_SORU.xlsm.html

 

[S.Yiğit]

Soykan bey merhaba,

Yardımınız için teşekkür ederim. Dosyayı indirmeye calıştığımda hata alıyorum, sanırım şirketin sistemden kaynaklanıyor. Rica etsem dosya.tc'den yükler misiniz?

 

[soykan]

http://s3.dosya.tc/server17/ceHiyX/NavlunTakipSORU.rar.html

 

[S.Yiğit]

Soykan bey merhaba,

Yardımınız için teşekkür ederim. Bu dosyada işimizi görür ancak derdimiz formül kullanmadan makro ile istediğimiz verileri getirmek. makronun tetiklenmesi de A sütununa tarih yazdıgımda olmalı.

 

[soykan]

Dövizi de aynı anda merkez bankasından mı almasını istiyorsunuz? Yoksa dövizi örnekteki gibi başka bir sayfada data olarak tutmak mı istiyorsunuz? Anladığım kadarı ile tatil günlerinde de bu işlemi yapıyorsunuz Merkez Bankasında o günler ile ilgili kur olmadığından onu da çözmemiz gerekir.

 

[S.Yiğit]

Yok cumartesi pazar ve resmi tatillerde çekme işlemi olmayacak. Başka sayfa olmadan A sütununa tarih yazdığımda o tarihe ait paremetre ve kurları çekerse benim için yeterlidir. Teşekkürler.

 

[soykan]

Linkden indirebilirsiniz.
http://www.dosya.tc/server23/ACvVvF/NavlunTakipSORU.rar.html

 

[S.Yiğit]

Soykan bey merhaba,

Çalışma için teşekkürler. Sanırım kurları yanlış çekiyor. 2013 Aralık ayından birkaç gün çektim farklı sonuçlar gösterdi.

 

[soykan]

Kontrol ettim 2013 den de kurları getirdim bir problem yok. Yalnız şuna dikkat ediniz. A sütununda hep son girdiğiniz satırı baz alıyor. Arada bir satır girerseniz en son satırdaki kuru getirir.

 

[Korhan Ayhan]

Sayfanızın kod bölümüne aşağıdaki kodu uygulayıp deneyiniz.

Option Explicit

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 BUL_PARİTE As Range, PARİTE As Double
    
    Set S1 = Sheets("Navlun Takip")
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DÖVİZLER").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set S2 = Sheets.Add(After:=Sheets(Worksheets.Count))
    ActiveSheet.Name = "DÖVİZLER"
    
    S1.Activate
    
    If Intersect(Target, Range("A11:A" & Rows.Count)) Is Nothing Then Exit Sub
    If Target.Count > 1 Then GoTo Çıkış
    If IsNumeric(Target) = False And IsDate(Target) = False Then
    MsgBox "Lütfen tarih giriniz !", vbCritical, "Dikkat !"
    Target.Select
    Application.EnableEvents = False
    Target.ClearContents
    Application.EnableEvents = True
    GoTo Çıkış
    End If
    
    With Application
    .DecimalSeparator = "."
    .ThousandsSeparator = ","
    .UseSystemSeparators = False
    End With
    
    GÜN = Format(Day(Cells(Target.Row, "A")), "00")
    AY = Format(Month(Cells(Target.Row, "A")), "00")
    YIL = Format(Year(Cells(Target.Row, "A")), "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 !"
    Target.Select
    GoTo Çıkış
    End If
        
    If TARİH = Date And Time <= TimeSerial(15, 30, 0) Then
    MsgBox "Bugüne ait gösterge niteliğindeki kurlar saat 15:30 sonrasında güncellenmektedir. Lütfen tarihi kontrol ediniz.", vbQuestion, "DİKKAT !"
    If MsgBox("Önceki güne ait kurlar alınacaktır. Onaylıyor musunuz?", vbExclamation + vbYesNo, "DİKKAT !") = vbYes Then
    TARİH = TARİH - 1
    Else
    GoTo Çıkış
    End If
    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
    
    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
    End If
    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 BUL_PARİTE = S2.Range("A:A").Find("EUR/USD", , , xlWhole)
    If Not BUL_PARİTE Is Nothing Then
        PARİTE = Replace(Replace(BUL_PARİTE.Offset(0, 2), ".", ","), " ABD D", "")
    End If
    
    Application.EnableEvents = False
    Cells(Target.Row, "L") = PARİTE
    Cells(Target.Row, "M") = S2.Cells(EUR_SATIR, EUR_SÜTUN)
    Cells(Target.Row, "N") = S2.Cells(USD_SATIR, USD_SÜTUN)
    
    With Application
    .UseSystemSeparators = True
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    GoTo Çıkış
    Exit Sub

Son:
MsgBox "İnternet bağlantısı şu anda kurulamıyor !" & vbCrLf & "Lütfen daha sonra tekrar deneyin.", vbCritical, "UYARI !"

Çıkış:
    Application.EnableEvents = True
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DÖVİZLER").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

 

[S.Yiğit]

Sayın Hocam,

Merhaba,

Yine gecenin geç saati çözüm bulmuşsunuz. Kod hızlı ve güzel olmuş. Elinize, emeğinize sağlık. Teşekkürler.

 

[halit3]

Alternatif kod

Kodu sayfanın kod bölümüne yapıştırın ve A sütünundaki hücreye tarih yazın enter tıklayın.

kod:

Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 10 Then
If Target.Column = 1 Then

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim say(4)

Dim URL As String
Dim IE As Object

URL = "http://www.tcmb.gov.tr/yeni/kurlar/kurlar_tr.php"


If IsDate(Target.Value) = False Then MsgBox "Başlangıç tarihi yanlış": Exit Sub

Tarih = CDate(Target.Value)

If Tarih < CDate(Format("01.01.2005", "dd.mm.yyyy")) Then MsgBox "01.01.2005 dan küçük olamaz.": Exit Sub
If CDate(Tarih) > Format(Now, "dd/mm/yyyy") Then MsgBox "Veri alınacak tarih bugünden büyük olamaz.": Exit Sub


If CDate(Tarih) = CDate(Format(Now, "dd.mm.yyyy")) And "15:30:00" >= CDate(Format(Now, "hh:nn")) Then
MsgBox "Bugün işlem yok saat 15:30:00 dan sonra yeniden deneyiniz."
Exit Sub
End If

If "01.01" = Format((Tarih), "dd/mm") Or "23.04" = Format((Tarih), "dd/mm") Or "01.05" = Format((Tarih), "dd/mm") Or "19.05" = Format((Tarih), "dd/mm") _
Or "30.08" = Format((Tarih), "dd/mm") Or "28.10" = Format((Tarih), "dd/mm") Or "29.10" = Format((Tarih), "dd/mm") Then: Cells(Target.Row, 12).Value = "Bugün Bayram": Cells(Target.Row, 13).Value = "Bugün Bayram": Cells(Target.Row, 14).Value = "Bugün Bayram": Exit Sub

If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then Cells(Target.Row, 12).Value = "Bugün Tatil": Cells(Target.Row, 13).Value = "Bugün Tatil": Cells(Target.Row, 14).Value = "Bugün Tatil": Exit Sub


Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate URL
.Visible = 0
apiShowWindow IE.hWnd, 2


deg1 = Format(Val(Mid(Tarih, 1, 2)), "00")
deg2 = Format(Val(Mid(Tarih, 4, 2)), "00")
deg3 = Format(Val(Mid(Tarih, 7, 4)), "00")

URL1 = "http://www.tcmb.gov.tr/kurlar/" & deg3 & deg2 & "/" & deg1 & deg2 & deg3 & ".html"
.Navigate URL1

Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

Set html_tba = IE.Document.getElementsByTagName("Body")
adres = Replace(Replace(WorksheetFunction.Trim(html_tba(0).InnerText), Chr(13), ""), Chr(10), " ")
If Mid(Replace(adres, " ", ""), 1, 20) <> "SayfaGörüntülenemedi" Then

sat1 = Val(InStr(Trim(adres), "USD/TRY"))
sat2 = Val(InStr(Trim(adres), "ÇAPRAZ KURLAR"))
sonsat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

If sat1 + sat2 <> 0 Then

say(1) = "USD/TRY"
say(2) = "EUR/TRY"
say(3) = "EUR/USD"

sut = 4
sat = 13
For r = 1 To 3
AlinacakVeri = say(r)
For j = 1 To Len(adres)
bulunan1 = InStr(j, adres, AlinacakVeri, vbTextCompare)
If bulunan1 > 0 Then
deg6 = Mid(adres, bulunan1 + Len(AlinacakVeri), Len(adres))
bolme = Split(deg6, " ")
If IsNumeric(bolme(sut)) = True Then
Cells(Target.Row, sat).Value = bolme(sut)
Cells(Target.Row, sat).NumberFormat = "General"
sat = sat + 1
End If
Exit For
End If
Next j
If r = 2 Then sut = sut - 1
If sat = 15 Then sat = 12
Next r
                         
End If

End If

IE.Quit: Set IE = Nothing
End With



MsgBox ("Bitti  ")
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End If
End Sub

 

[S.Yiğit]

Sayın halit hocam,

Merhaba,

Sizede teşekkür ederim. Elinize emeğinize sağlık.

 

[halit3]

Bu kod birazcık daha kısa

kod:

Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 10 Then
If Target.Column = 1 Then

Application.ScreenUpdating = False
Application.DisplayAlerts = False


Dim IE As Object, URL As String

URL = "http://www.tcmb.gov.tr/yeni/kurlar/kurlar_tr.php"


If IsDate(Target.Value) = False Then MsgBox "Başlangıç tarihi yanlış": Exit Sub

Tarih = CDate(Target.Value)

If Tarih < CDate(Format("01.01.2005", "dd.mm.yyyy")) Then MsgBox "01.01.2005 dan küçük olamaz.": Exit Sub
If CDate(Tarih) > Format(Now, "dd/mm/yyyy") Then MsgBox "Veri alınacak tarih bugünden büyük olamaz.": Exit Sub


If CDate(Tarih) = CDate(Format(Now, "dd.mm.yyyy")) And "15:30:00" >= CDate(Format(Now, "hh:nn")) Then
MsgBox "Bugün işlem yok saat 15:30:00 dan sonra yeniden deneyiniz."
Exit Sub
End If

If "01.01" = Format((Tarih), "dd/mm") Or "23.04" = Format((Tarih), "dd/mm") Or "01.05" = Format((Tarih), "dd/mm") Or "19.05" = Format((Tarih), "dd/mm") _
Or "30.08" = Format((Tarih), "dd/mm") Or "28.10" = Format((Tarih), "dd/mm") Or "29.10" = Format((Tarih), "dd/mm") Then: Cells(Target.Row, 12).Value = "Bugün Bayram": Cells(Target.Row, 13).Value = "Bugün Bayram": Cells(Target.Row, 14).Value = "Bugün Bayram": Exit Sub

If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then Cells(Target.Row, 12).Value = "Bugün Tatil": Cells(Target.Row, 13).Value = "Bugün Tatil": Cells(Target.Row, 14).Value = "Bugün Tatil": Exit Sub


Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate URL
.Visible = 0
apiShowWindow IE.hWnd, 2


deg1 = Format(Val(Mid(Tarih, 1, 2)), "00")
deg2 = Format(Val(Mid(Tarih, 4, 2)), "00")
deg3 = Format(Val(Mid(Tarih, 7, 4)), "00")

URL1 = "http://www.tcmb.gov.tr/kurlar/" & deg3 & deg2 & "/" & deg1 & deg2 & deg3 & ".html"
.Navigate URL1

Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

Set html_tba = IE.Document.getElementsByTagName("Body")
adres = Replace(Replace(WorksheetFunction.Trim(html_tba(0).InnerText), Chr(13), ""), Chr(10), " ")


If Mid(Replace(adres, " ", ""), 1, 20) <> "SayfaGörüntülenemedi" Then

[COLOR="Red"]deg1 = Split(adres, "USD/TRY")
If UBound(deg1) > 0 Then
deg2 = Split(deg1(1), " ")
Cells(Target.Row, 13).Value = deg2(4)
End If

deg3 = Split(adres, "EUR/TRY")
If UBound(deg3) > 0 Then
deg4 = Split(deg3(1), " ")
Cells(Target.Row, 14).Value = deg4(4)
End If

deg5 = Split(adres, "EUR/USD")
If UBound(deg5) > 0 Then
deg6 = Split(deg5(1), " ")
Cells(Target.Row, 12).Value = deg6(3)
End If[/COLOR]

                         
End If



IE.Quit: Set IE = Nothing
End With



MsgBox ("Bitti  ")
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End If
End Sub

 

[S.Yiğit]

Sayfanızın kod bölümüne aşağıdaki kodu uygulayıp deneyiniz.


Set S1 = Sheets("Navlun Takip") Navlun takip olan yeri Tablo olarak değiştirdim. Yeni açtığım sayfanın adı FT Talepleri

Korhan hocam merhaba,

11 nolu mesajınızdaki kodu başka bir çalışmamda kullanıyorum. Sağ tarafına aynı tablodan bir tane daha ekledim. Sayfa isimlerini de değiştirdim. Yanlız yeni sayfada ne işlem yaparsam yapayım kurları çektiğim sayfaya gidiyor, sonrasında yeni tabloya gitmek zorunda kalıyorum. Kodda nasıl bir değişiklik yapmamız gerekiyor?