[alacatan]

Bugün denediğimde https ile sonuçları verdi. Fonksiyonu aşağıdaki şekilde kullanabiliyorsunuz:

Elinize sağlık Hocam gayet güzel çalışıyor.

Aynı problem ETA'da da var, birkaç gündür kur güncellemesi yapılamıyor programdan.
ETA'nın kur takibi bölümündeki servis kısmının resmini aşağıya ekliyorum.

Buradaki url dizinini ve url dosya adını değiştirerek güncelleme yapılabilinir mi, ne dersiniz?

Saygılar.

[Tarkan VURAL]

URL doğru görünüyor.

[alacatan]

Programdan kaynaklanıyor öyleyse.
Yanıt için teşekkürler Hocam.

[bcagatay75]

Bugün denediğimde https ile sonuçları verdi. Fonksiyonu aşağıdaki şekilde kullanabiliyorsunuz:

Kod: Tümünü seç

DefVar E
Function Webdoviz(ByVal Tarih As Date, ByVal Dovtip As String, ByVal Tipi As Long) As Variant
Dim gun As String, ay As String, yil As String, path As String, kur As Double
Dim icerik As String, xmlhttp As Object, evn As Variant
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
Application.Volatile
Dovtip = UCase(Dovtip)
gun = Day(Tarih): ay = Month(Tarih): yil = Year(Tarih)
If Len(gun) = 1 Then gun = "0" & gun
If Len(ay) = 1 Then ay = "0" & ay
path = "https://www.tcmb.gov.tr/kurlar/" & yil & ay & "/" & gun & ay & yil & ".xml"
xmlhttp.Open "GET", path, False
xmlhttp.send "at"
If xmlhttp.Status = 200 Then
    icerik = xmlhttp.responseText
    temizlik = Split(icerik, "<Currency CrossOrder=")
    For y = 0 To UBound(temizlik)
        If temizlik(y) Like "*=""" & Dovtip & "*" Then
            sonuclar = Split(temizlik(y), "</CurrencyName>")
            evn1 = Split(sonuclar(1), "<ForexBuying>")
            evn2 = Split(sonuclar(1), "<ForexSelling>")
            evn3 = Split(sonuclar(1), "<BanknoteBuying>")
            evn4 = Split(sonuclar(1), "<BanknoteSelling>")
            Select Case Tipi
                Case 1: evn = Split(evn1(1), "</")
                Case 2: evn = Split(evn2(1), "</")
                Case 3: evn = Split(evn3(1), "</")
                Case 4: evn = Split(evn4(1), "</")
            End Select
            Exit For
        End If
    Next y
End If
'Kuruş hanesini benim gibi virgül kullananlar için
Webdoviz = Replace(evn(0), ".", ",")

'Kuruş hanesini nokta kullananlar için
'Webdoviz = evn(0)
End Function



harika oldu çok teşekkürler.
Burak Çağatay

[romanci05]

Merhaba,

Ben aynı soruna şu şekilde çözüm üretmiştim.

Dim A As String, B As String, c As String, path As String, kur As Double
Dim icerik As String, xmlhttp As Object, evn As Variant
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Application.Volatile
Dovtip = UCase(Dovtip)

MSXML2.XMLHTTP yerine MSXML2.SERVERXMLHTTP yazınca çalışıyor.

Bilgilerinize.

[burhany]

Merhaba

çok şey denedim çalıştıramadım.ecxell hali mevcutmudur. inceleme imkanı olursa iyi olur. teşekkürler

[akyildizyucel]

merhaba , kod çalışıyor , verileri çektiği sayfanın başlıklarını da çekebilir mi ?

Merhaba Mehmet Bey,

Sitedeki verileri formatlarından kaynaklanıyor. Aynı durum USD/JPY de de mevcut. İlaveten en alt tablodaki SDR/USD formatı da farklı olduğundan hatalı geliyor. Bu formatları düzenlemek gerek..

Kodları revize ettim. Bu kodları kullanabilirsiniz;

Kod: Tümünü seç

Sub Emre()
    Application.ScreenUpdating = False
    Dim alan As Range
    Cells.Clear
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.tcmb.gov.tr/kurlar/today.xml", Destination:=Range("$A$1"))
        .Name = "today_1"
        .Refresh BackgroundQuery:=False
    End With
    Range("AB1000").Value = "10000"
    Range("AB1000").Copy
    Set alan = Range("D3:G20,D25:D41,D44:D45")
    alan.Select
    For Each evn In alan
    If Left(evn.Value, 2) = 10 Then
        evn.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        evn.Value = CDbl(evn.Value)
    ElseIf Left(evn.Value, 1) > 0 Then
        evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
            ElseIf Left(evn.Value, 1) = 0 Then
        evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, SkipBlanks:=False, Transpose:=False
        evn.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks:=False, Transpose:=False
    End If
    Next evn
    Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Application.CutCopyMode = False
    Columns("D:G").NumberFormat = "#,##0.0000"
    Range("D44").Value = Range("D44").Value / 10
    Range("D44").NumberFormat = "#,##0.00000"
    Cells.Font.Size = 8: Columns.AutoFit
    Application.ScreenUpdating = True
End Sub