Farklı siteden bilgi alımı için kodların düzeni

[irfancantr]

Merhaba değerli forum üyeleri,

Aşağıda bulunan kod Sn. Zeki Bey'in hazırladığı ilgili web sitesinden bilgi almak için hazırlanmıştır.

Private Sub Makro1(alt As Long, ust As Long)
Const URL = "[COLOR="Red"]http://www.motorsporlari.net/car/[/COLOR]"
    
    With Sayfa3
        
        For L = alt To ust
            
            Set HTTP = CreateObject("MSXML2.XMLHTTP")
            Set doc = CreateObject("HTMLFile")

            DoEvents
            
            Application.StatusBar = L & " / " & ust & " işlemi yapılıyor..."
            
            .Range("A1:B100").ClearContents
            
            HTTP.Open "get", URL & Sayfa1.Cells(L, "d"), False
            HTTP.send
            
            doc.write (StrConv(HTTP.responsebody, vbUnicode))
            
            Set tbl = doc.getElementsByTagName("table").Item([COLOR="red"]3[/COLOR])
            
            For i = 0 To tbl.Rows.Length - 1
                DoEvents
                For j = 0 To tbl.Rows(i).Cells.Length - 1
                    DoEvents
                    .Cells(i + 1, j + 1) = tbl.Rows(i).Cells(j).innerText
                Next
            Next
            
            For M = 100 To 1 Step -1
                DoEvents
                If Len(.Cells(M, "a")) = 0 Then _
                    .Range("a" & M & ":b" & M).Delete (xlUp)
            Next
            
            .Cells(L + 1, "d") = L
            
            For N = 1 To 83
                DoEvents
                .Cells(L + 1, N + 4) = .Cells(N + 1, "b")
            Next
            
            .Cells(L + 1, "d").Select
            
            Set tbl = Nothing
            Set doc = Nothing
            Set HTTP = Nothing
        Next
        
    End With
    
    Application.StatusBar = False
    
    MsgBox "İşlem tamamlandı. Dosya kaydedilip kapatılacak." & Chr(13) & _
        "Sonraki '1000' adres için 'Test' makrosunu düzenleyin", vbInformation
        
    ThisWorkbook.Close True
End Sub

Yukarıda bulunan kodların dosya örneği ektedir.


Bu site için hazırlanmış kod da bulunan kırmızı renkte olan değerleri ilgilendiğim diğer bir site için değiştirmem sanırım yeterli olmuyor.

Renault megane Bilgi alınacak table numarası ise 1.

Benim bu siteden aynı yöntem ile veri alabilmem için ne gibi değişiklikler yapmam gerekiyor.

Konu ile ilgilenen herkese şimdi çok teşekkür ediyorum.

 

[Zeki Gürsoy]

Sub Makro22()
    Const URL = "http://www.auto-data.net/tr/?f=showCar&car_id=10528"      
            
            Set HTTP = CreateObject("MSXML2.XMLHTTP")
            Set doc = CreateObject("HTMLFile")
            
            HTTP.Open "get", URL, False
            HTTP.send
            
            doc.write (HTTP.responseText)
            
            Set tbl = doc.getElementsByTagName("table").Item(0)
            
            For i = 0 To tbl.Rows.Length - 1
                For j = 0 To tbl.Rows(i).Cells.Length - 1
                    Sayfa3.Cells(i + 1, j + 1) = tbl.Rows(i).Cells(j).innerText
                Next
            Next
            
            Set tbl = Nothing
            Set doc = Nothing
            Set HTTP = Nothing 
        
End Sub

 

[irfancantr]

Sub Makro22()
    Const URL = "http://www.auto-data.net/tr/?f=showCar&car_id=10528"      
            
            Set HTTP = CreateObject("MSXML2.XMLHTTP")
            Set doc = CreateObject("HTMLFile")
            
            HTTP.Open "get", URL, False
            HTTP.send
            
            doc.write (HTTP.responseText)
            
            Set tbl = doc.getElementsByTagName("table").Item(0)
            
            For i = 0 To tbl.Rows.Length - 1
                For j = 0 To tbl.Rows(i).Cells.Length - 1
                    Sayfa3.Cells(i + 1, j + 1) = tbl.Rows(i).Cells(j).innerText
                Next
            Next
            
            Set tbl = Nothing
            Set doc = Nothing
            Set HTTP = Nothing 
        
End Sub

Zeki Hocam emeğine ve zekana sağlık, daha yeni girebildim siteye. Yardımlarınız için çok teşekkür ediyorum.