Soru web sayfasındaki linklerin içerisinden bilgileri toplama

Option Explicit
 Const link1 = "https://www.cersaie.it/en/e_dettaglio.php?CODICE=4578&PREVQUERY=NAZIONE%3DI__Italy"
 Const link2 = "https://www.cersaie.it/en/e_dettaglio.php?CODICE=4837&PREVQUERY=NAZIONE%3DI__Italy"
 Const link3 = "https://www.cersaie.it/en/e_dettaglio.php?CODICE=5314&PREVQUERY=NAZIONE%3DI__Italy"
 Const link4 = "https://www.cersaie.it/en/e_dettaglio.php?CODICE=5223&PREVQUERY=NAZIONE%3DI__Italy"
Private Sub Düğme1_Tıkla()
Dim arr1 As New clsArray2D, arr As Variant, arr2 As New clsArray2D, arr3 As New clsArray2D, veri, s As Long, x As Long
ReDim veri(0 To 0)
arr = arr1.WEBtoArray(link1, vbLf, False, True, True, True, True, False) ' VbLf, vbCrLf & vbCr
arr2.ArraydenYukle (arr)
s = Application.Match("*@*", arr, 0) - 1
x = x + 1
ReDim Preserve veri(1 To x)
veri(x) = arr(s)
arr = Empty
arr = arr1.WEBtoArray(link2, vbLf, False, True, True, True, True, False) ' VbLf, vbCrLf & vbCr
arr2.ArraydenYukle (arr)
s = Application.Match("*@*", arr, 0) - 1
x = x + 1
ReDim Preserve veri(1 To x)
veri(x) = arr(s)
arr = Empty

arr = arr1.WEBtoArray(link3, vbLf, False, True, True, True, True, False) ' VbLf, vbCrLf & vbCr
arr2.ArraydenYukle (arr)
s = Application.Match("*@*", arr, 0) - 1
x = x + 1
ReDim Preserve veri(1 To x)
veri(x) = arr(s)
arr = Empty

arr = arr1.WEBtoArray(link4, vbLf, False, True, True, True, True, False) ' VbLf, vbCrLf & vbCr
arr2.ArraydenYukle (arr)
s = Application.Match("*@*", arr, 0) - 1
x = x + 1
ReDim Preserve veri(1 To x)
veri(x) = arr(s)
Range("A2").Resize(UBound(veri), 1) = Application.transpose(veri)
arr = Empty

End Sub

Private Sub CommandButton3_Click()
Dim ie As New InternetExplorer
Dim itemEle As Object
Dim pt1 As Variant
Dim i As Integer
Dim q As Integer
Dim g As Variant
Dim m As Integer
Dim sonuc As Variant
Dim satır As Variant
Dim elements As Object
On Error Resume Next
Set ie = CreateObject("internetexplorer.application")
ie.navigate "https://www.cersaie.it/en/e_lista.php?RAGSOC=&RAGSOC__1=&NAZIONE=I__Italy&REGIONE=&PRODOTTO=&EN_DESCRIZIONE=&submit=Search"
ie.Visible = False
m = 1
Worksheets("Sayfa1").Range("A1:C65536").Clear
Do While ie.ReadyState <> 4
DoEvents
Loop
Application.Wait (Now + TimeValue("0:00:01"))
For i = 0 To 384
    g = ie.document.getElementsByTagName("table").Item(0).Children(0).Children(i).Children(0).innerHTML
    satır = Mid(g, WorksheetFunction.Find("&amp", g, 1) - 4, 4)
    Worksheets("Sayfa1").Cells(m, 1).Value = satır
    m = m + 1
    DoEvents
Next i
ie.Quit
Set ie = Nothing

Dim kod As Variant
Dim x As Integer
For x = 1 To 384
   
    kod = Worksheets("Sayfa1").Cells(x, 1).Value
    If kod <> "" Then
        If InStr(kod, "=") > 0 Then
            kod = Split(kod, "=")(1)
        End If
        Set ie = CreateObject("internetexplorer.application")
       
        ie.navigate "https://www.cersaie.it/en/e_dettaglio.php?CODICE=" & kod & "&PREVQUERY=NAZIONE%3DI__Italy"
        ie.Visible = False
       
        Do While ie.ReadyState <> 4
        DoEvents
        Loop
        Application.Wait (Now + TimeValue("0:00:01"))
           
        sonuc = ie.document.getElementsByClassName("settanta").Item(5).Children(0).innerHTML
        firm = ie.document.getElementsByClassName("settanta").Item(0).innerHTML
        Cells(x, 1).Select
        Worksheets("Sayfa1").Cells(x, 3).Value = sonuc
        Worksheets("Sayfa1").Cells(x, 2).Value = firm
        sonuc = ""
        firm = ""
        ie.Quit
        Set ie = Nothing
    End If

Next x

Worksheets("Sayfa1").Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft


End Sub