Web'ten Altin Fiyatlarını Çekme

Bu siteden bilgi çekmek istiyorum

yardımcı olur musunuz. Tekrar konu açmam mı gerekiyor?

Butonun tıklandığında olayına aşağıdaki kodu ekle.

   Dim appIE As Object

    Dim HTML_Body As Object, HTML_Tables As Object, MyTable As Object

    Dim HTML_TableRows As Object

    Dim RetVal As Variant, X As Integer

    Dim GSatirSayisi As Integer

    

    Const GLink As String = "https://www.canlialtinfiyatlari.com/"

     

   

    Set appIE = CreateObject("internetexplorer.application")

    

    With appIE

        .Navigate GLink

        .Visible = False

    End With



    Do While appIE.Busy: DoEvents: Loop

    

        



        Set HTML_Body = appIE.Document.All

        Set HTML_Tables = HTML_Body.tags("Table")

        Set MyTable = HTML_Tables(2)

        Set HTML_TableRows = MyTable.getElementsByTagName("tr")

        

        GSatirSayisi = HTML_TableRows.Length - 1

        

        ReDim Sorgu(3, GSatirSayisi - 1)



        

        X = 0

        For X = 0 To GSatirSayisi - 1

                                             

            Sorgu(0, X) = MyTable.Rows(X + 1).Cells(0).innerText

            Sorgu(1, X) = MyTable.Rows(X + 1).Cells(1).innerText

            Sorgu(2, X) = MyTable.Rows(X + 1).Cells(2).innerText



         Next X



    Dim rc As DAO.Recordset

    Set rc = CurrentDb.OpenRecordset("Tbl_Altin")

    

    X = 0

    

    For X = 0 To GSatirSayisi - 1

    

        rc.AddNew

            rc![AltınTuru] = Sorgu(0, X)

            rc![Alis] = Sorgu(1, X)

            rc![Satis] = Sorgu(2, X)



        rc.Update

    Next X

    

    Set rc = Nothing

    Me.Alt0.Requery

    

    appIE.Quit

    Set HTML_Body = Nothing

    Set HTML_Tables = Nothing

    Set MyTable = Nothing

    Set HTML_TableRows = Nothing

    Set appIE = Nothing

Ozan bey ne kadar çok teşekkür etsem azdır. Elinize sağlık oldu.

Sayenizde Web den veri çekme olayına el attım bakalım öğrenebilecekmiyim MSXML2.XMLHTTP bu yöntem hızlı olduğu için bununa yaptım.
Veri alırken başlıksız aldıramadığım için For x = 2 To UBound(arr, 2) burda döngüyü 2 den başlattım.
Anlayan varsa buna bir çözüm bulursa sevinirim.
Kısaca kod verileri alıyor.

Option Compare Database



Private Sub Getir_Click()

    Dim url As String

    Dim j As Integer, row As Integer

    Dim XMLHTTP As Object, Html As Object

    Dim tr As Object

    Dim td As Object, tbl

    Dim arr(), x As Integer

    

    Dim rc As DAO.Recordset

    Set rc = CurrentDb.OpenRecordset("Tbl_Altin")



    

    url = "https://www.canlialtinfiyatlari.com/"



    Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")

    XMLHTTP.Open "GET", url, False

    XMLHTTP.send



    Set Html = CreateObject("htmlfile")

    html.body.innerHTML = XMLHTTP.responseText



    Set tbl = html.body.getElementsByTagName("table")



    For Each t In tbl

        If t.className = "altin-table-2" Then

            For Each tr In t.getElementsByTagName("TR")

                j = 1

                For Each td In tr.getElementsByTagName("TD")

                  ReDim Preserve arr(1 To 3, 1 To row + 1)

                    If j < 4 Then arr(j, row + 1) = td.innerText

                    j = j + 1

                Next

                row = row + 1

            Next

            row = row + 3

        End If

    Next

    

    CurrentDb.Execute ("delete from Tbl_Altin")

    For x = 2 To UBound(arr, 2)

        rc.AddNew

            rc(0) = arr(1, x)

            rc(1) = arr(2, x)

            rc(2) = arr(3, x)



        rc.Update

    Next x

    

    Set rc = Nothing

    Me.Alt0.Requery

 

    Erase arr: Set XMLHTTP = Nothing: Set Html = Nothing

    Set tr = Nothing: Set td = Nothing



End Sub

Rakamlar doğru formatta gelmiyormuş alttaki gibi yapınca düzeldi

For Each td In tr.getElementsByTagName("TD")

        ReDim Preserve arr(1 To 3, 1 To row + 1)

        If j = 1 Then arr(j, row + 1) = td.innerText

        If j = 2 Or j = 3 Then arr(j, row + 1) = Replace(td.innerText, ".", ",")

        j = j + 1

  Next

Harikasınız elinize sağlık