• DİKKAT

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

döviz kuru sorgulama

1

1903emre34@gmail.com

Altın Üye
Katılım
29 Mayıs 2016
Mesajlar
946
Excel Vers. ve Dili
Microsoft Excel 2013 Türkçe
Merhabalar,

aşağıdaki kod ile girilen tarihler arasında döviz kurlarını ekrana gelmesini sağlıyor , yalnız resmi tatil günlerinde bile ekrana döviz kurları getiriyor kodlarda nasıl değişiklik yapabiliriz? Resmi,iş tatil gün denk gelirse -- çizgi gelsin
Kod: 
Option Explicit

Sub SORGULA()
    Dim SR As Worksheet, Sayfa_Adı As String, SK As Worksheet
    Dim X, Y, Z, KONTROL As Byte
    Dim URL1 As String, SATIR As Long, SAY As Byte
    Dim EURO_BUL As Range, EURO_SATIR As Long, SÜTUN As Integer, EURO_SÜTUN As Byte
    Dim USD_BUL As Range, USD_SATIR As Long, USD_SÜTUN As Byte
    Dim GBP_BUL As Range, GBP_SATIR As Long, GBP_SÜTUN As Byte
    Dim Versiyon As Byte
    
    Application.ScreenUpdating = False
    
    Versiyon = Val(Application.Version)
    
    Set SR = Sheets("RAPOR")
    SR.Select
    If [B1] = "" Then MsgBox "Lütfen ilk tarihi giriniz !", vbExclamation, "Dikkat !": [B1].Select: Exit Sub
    If [B2] = "" Then MsgBox "Lütfen son tarihi giriniz !", vbExclamation, "Dikkat !": [B2].Select: Exit Sub
    If [B2] < [B1] Then
    MsgBox "Son tarih ilk tarihten küçük olamaz !" _
    & Chr(10) & Chr(10) & "Lütfen girdiğiniz bilgileri kontrol ediniz.", vbCritical, "Dikkat !"
    [B2].ClearContents
    [B2].Select
    Exit Sub
    End If
    
    [A6:M65536].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
    Application.Wait (Now + TimeValue("0:00:01"))
    
    For X = SR.[B1] - 1 To SR.[B2] - 1
    If X > Date - 1 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
    
    
    
    
    Set EURO_BUL = SK.[A:A].Find(What:="EUR", LookAt:=xlPart)
    If Not EURO_BUL Is Nothing Then
    EURO_SATIR = EURO_BUL.Row
    
    For SÜTUN = 2 To 256
    SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "Döviz Alış") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "Forex Buying")
    If IsNumeric(Right(SK.Cells(EURO_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
    EURO_SÜTUN = SÜTUN
    Exit For
    End If
    Next
    End If
    
    
    
    
    Set USD_BUL = SK.[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(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "Döviz Alış") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "Forex Buying")
    If IsNumeric(Right(SK.Cells(USD_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
    USD_SÜTUN = SÜTUN
    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
    
    For SÜTUN = 2 To 256
    SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "Döviz Alış") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "Forex Buying")
    If IsNumeric(Right(SK.Cells(GBP_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
    GBP_SÜTUN = SÜTUN
    Exit For
    End If
    Next
    End If
    
    
    
    
    SR.Cells(SATIR, 1) = X + 1
    SR.Cells(SATIR, 2) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 3) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 1) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 4) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 2) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 5) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 3) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 6) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 7) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 1), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 1), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 1) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 8) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 2), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 2), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 2) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 9) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 3), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 3), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 3) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 10) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 11) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN + 1), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN + 1), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN + 1) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 12) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN + 2), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN + 2), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN + 2) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 13) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN + 3), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN + 3), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN + 3) / IIf(Versiyon < 12, 10000, 1))
    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
    
    SR.Cells(SATIR, 1) = X + 1
    SR.Cells(SATIR, 2) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 3) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 1) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 4) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 2) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 5) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 3) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 6) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 1) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 7) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 1), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 1), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 1) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 8) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 2), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 2), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 2) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 9) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 3), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 3), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 3) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 10) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 11) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN + 1), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN + 1), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN + 1) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 12) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN + 2), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN + 2), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN + 2) / IIf(Versiyon < 12, 10000, 1))
    SR.Cells(SATIR, 13) = IIf(Left(SK.Cells(GBP_SATIR, GBP_SÜTUN + 3), 1) = 0, Replace(SK.Cells(GBP_SATIR, GBP_SÜTUN + 3), ".", ",") * 1, SK.Cells(GBP_SATIR, GBP_SÜTUN + 3) / IIf(Versiyon < 12, 10000, 1))
    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
[K1].Activate
    MsgBox "Döviz sorgulama işlemi başarıyla tamamlanmıştır.", 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
 
Merhaba
Ek dosyayı denermisiniz?
http://s3.dosya.tc/server10/zk72ka/tcm1.zip.html
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
Dim f, c As Integer
Dim i As Long
Dim d()
Dim ie, st, sts
Dim deg As String
Dim trh As Date
Dim trh1, trh2 As String
If IsDate([B1]) = False Or IsDate([B2]) = False Or [B2] - [B1] < 0 Then
MsgBox "İLK VE SON TARİH YOK VEYA HATALI"
Exit Sub
End If
[A5:F65000].ClearContents
For j = 0 To [B2] - [B1]
trh = DateAdd("d", j, [B1])
trh1 = Format(trh, "yyyymm")
trh2 = Format(trh, "ddmmyyyy")
Set ie = CreateObject("internetexplorer.application")
ie.Visible = False
ie.navigate "http://www.tcmb.gov.tr/kurlar/" & trh1 & "/" & trh2 & ".xml"
Do While ie.Busy And Not ie.readyState = READYSTATE_COMPLETE
DoEvents
Loop
Set st = ie.document
i = Cells(Rows.Count, 1).End(3).Row + 1
c = 1
Cells(i, c) = Format(trh, "dd.mm.yyyy")
On Error Resume Next
Set sts = st.getElementById("kurlarContainer").getElementsByTagName("td")
d = Array(2, 3, 4, 5, 6, 23, 24, 25, 26, 27, 30, 31, 32, 33, 34)
For s = 0 To UBound(d)
c = c + 1
If Err > 0 Then
deg = "-"
Else
deg = sts(d(s)).innertext
End If
Cells(i, c) = deg
If c = 6 Then c = 1: Cells(i, c) = Format(trh, "dd.mm.yyyy"): i = i + 1
Next
Set st = Nothing
Set kl = Nothing
Err = 0
ie.Quit
Next

End Sub[/SIZE]
 
Son düzenleme:
Merhaba
Örnek dosyanıza göre; aşağıdaki gibi deneyelim.
http://s3.dosya.tc/server10/qdp5jl/SORGU.zip.html
Kod: 
[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [H1]) Is Nothing Then Exit Sub
If Target.Address = "$H$1" Then Range("A6:M65536").ClearContents
If [H1] = "" Then Exit Sub
 Dim s As Integer
 Dim r As Range
 Dim trh As Date
 Dim sat As Long
Dim ie, st, kl, sts, bak, tex, trh1, trh2, x1
    With Application
    .DecimalSeparator = "."
    .ThousandsSeparator = ","
    .UseSystemSeparators = False
    End With
For j = 0 To [B2] - [B1]
trh = DateAdd("d", j, [B1])
trh1 = Format(trh, "yyyymm")
trh2 = Format(trh, "ddmmyyyy")
Set ie = CreateObject("internetexplorer.application")
ie.Visible = False
ie.navigate "http://www.tcmb.gov.tr/kurlar/" & trh1 & "/" & trh2 & ".xml"
Do While ie.Busy And Not ie.readyState = READYSTATE_COMPLETE
DoEvents
Loop
s = 0
On Error Resume Next
Set st = ie.document
Set sts = st.getElementById("kurlarContainer").getElementsByTagName("td")
sat = Cells(Rows.Count, "A").End(3).Row + 1
If Err > 0 Then
  Cells(sat, "A") = DateValue(trh)
Range("B" & sat & ":M" & sat) = "--"
End If
For Each bak In sts
s = s + 1
If bak.innertext <> "" Then
If Len(bak.innertext) > 4 And Right(Trim(bak.innertext), 4) = "/TRY" Then
Set r = [E1:H1].Find(Split(Trim(bak.innertext), "/TRY")(0), , xlValues, xlWhole)
If Not r Is Nothing Then
Cells(sat, "A") = DateValue(trh)
  If Err = 0 Then
  For Each x1 In Range("B4,F4,J4")
  If Trim(x1.Value) = Split(Trim(bak.innertext), "/TRY")(0) Then
Cells(sat, x1.Column) = sts(s + 2).innertext
Cells(sat, x1.Column + 1) = sts(s + 3).innertext
Cells(sat, x1.Column + 2) = sts(s + 4).innertext
Cells(sat, x1.Column + 3) = sts(s + 5).innertext
  End If
  Next
  End If

End If
Set r = Nothing
End If: End If
Next
Set st = Nothing
Set kl = Nothing
ie.Quit
Err = 0
Next
End Sub[/SIZE]
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst