Çözüldü Kuveytturk yada Harem altından veri alma

[mahsun494]

Hayırlı günler, sitenizde bu konu var eski bir konu exceli de tam olarak bilmediğim için bana yardım edebilir misiniz. Yardımlarınız için şimdiden teşekkür ediyorum.

Çözüldü - Siteden veri çekme(haremaltin.com)

Merhaba. Canlı Altın Fiyatları & Canlı Döviz Kurları | Harem Altın Öğrenmek için yukardaki sitede antreman yaptım yine sonuç başarısız. Daha önce bir üstad Api ile çok hızlı veri çekme dosya vermişti onuda yekledim buraya. CreateObject("MSXML2.XMLHTTP") yöntemi ile Canlı Altın Fiyatları &...

excelcozum.com

 

[Miraga]

merhabalar
yardım edilebilmesi için hangi konuda nasıl bir yardım istediğinizi ayrıntılı bir şekilde belirtirseniz konu hakkında bilgi sahibi arkadaşlar mutlak yardımcı olurlar.
ayrıca örnek bir dosya mutlaka olmalı

 

[Refaz]

Aslında o sitedeki çözüm json ilemiydi unuttum ama json ile yapılmıştı ve arşivdeydi.
Bir denersiniz.Olmazsa üstadın dediklerini uygulayın.

 

[mahsun494]

Aslında o sitedeki çözüm json ilemiydi unuttum ama json ile yapılmıştı ve arşivdeydi.
Bir denersiniz.Olmazsa üstadın dediklerini uygulayın.

Hocam yaptığınız api çalışıyor güvenlik nedeni ile yapamamıştım. Şimdi sorum şu apiyi otomatik güncelleme yapamaz mıyız. Her defasın da api getir butonuna tıklıyorum. Geç cevap verdiğim için özür diliyorum yardımlarınız için teşekkür ediyorum.

Bu arada Alttaki kod da kuveyttürk den altın verisi alma kodu

Sub GetData()
Dim HTTP As Object, HTML As Object
Dim URL As String
Dim Tables As Object, myTable As Object

Range("A1:C" & Rows.Count) = Empty

URL = "https://www.kuveytturk.com.tr/"

Set HTTP = CreateObject("MSXML2.XMLHTTP")
Set HTML = CreateObject("HTMLFILE")

HTTP.Open "GET", URL, False
HTTP.send

If HTTP.Status = 200 Then
HTML.body.innerHTML = HTTP.responseText
Set Tables = HTML.getelementsByTagName("Table")

Set myTable = Tables(3)

For i = 0 To myTable.Rows.Length - 1
For j = 0 To myTable.Rows(0).Cells.Length - 1
If j = 0 Then
Cells(i + 1, j + 1) = Split(myTable.Rows(i).Cells(j).innertext, vbLf)(0)
Else
Cells(i + 1, j + 1) = Replace(Split(myTable.Rows(i).Cells(j).innertext, vbLf)(1), ",", ".")
End If
Next
Next
End If

Set myTable = Nothing
Set Tables = Nothing
Set HTML = Nothing
Set HTTP = Nothing
End Sub

Yada şöyle denenebilir

Sub Test()
    Dim objHTTP As Object, strURL As String, HTMLcode As String
    
    Range("D3:E3, H3:I3, L3:M3") = ""
    
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    strURL = "https://www.kuveytturk.com.tr/ck0d84?8C5CC4B13366803C5CD94EA5A2119E69"
    
    objHTTP.Open "GET", strURL, False
    objHTTP.send
    
    HTMLcode = objHTTP.responseText
    
    Set regExp = CreateObject("VBScript.RegExp")
    
    regExp.ignorecase = True
    regExp.Global = True
          
    regExp.Pattern = """BuyRate"":""(.+?)"",""SellRate"":""(.+?)"""
        
    If regExp.Test(HTMLcode) Then
        Set objMatches = regExp.Execute(HTMLcode)
                    
        [D3] = Replace(objMatches.Item(1).submatches(0), ",", ".")
        [E3] = Replace(objMatches.Item(1).submatches(1), ",", ".")
        [H3] = Replace(objMatches.Item(2).submatches(0), ",", ".")
        [I3] = Replace(objMatches.Item(2).submatches(1), ",", ".")
        [L3] = Replace(objMatches.Item(3).submatches(0), ".", "")
        [M3] = Replace(objMatches.Item(3).submatches(1), ".", "")
    End If
    
    Range("D3:E3, H3:I3, L3:M3").NumberFormat = "0.00"
    
    Set objMatches = Nothing
    Set regExp = Nothing
    Set objHTTP = Nothing
End Sub

 

[Refaz]

Rica ederim.Api yi başkası yazmıştı.Güncelleme derken mesela açılıştamı,her bir dakikadamı vs... çalışacak kod.Açılış için workbokksopen koduna ekeyebilirsiniz diğeri için application.ontime kodunu inceleyin internette.