websitesine ait tüm tablo ve içerikleri indirme.

[ridvansahin]

Öncelikle mutlu bir haftasonu diliyorum.
Excelin websitesinden veri alma özelliği mevcut. Fakat 2000 sayfaya ait bir websitesinin tamamını aktarabilecek bir makro mevcut mudur? Ben bir tane buldum ama bu makroyu nasıl ekleyip çalıştıracağımı bilmiyorum.Alt tarafa ekledim makroyu. Ayrıca bu yazılım sadece bir websitesinde işlem yapmak için işe yarıyor gibi duruyor. Website linkinin girileceği yeri değişken olarak yapılması mümkün mü?Teşekkürler iyi çalışmalar.

Private Sub Test()

Dim ie As Object, i As Long, strText As String

Dim doc As Object, hTable As Object, hBody As Object, hTR As Object, hTD As Object
Dim tb As Object, bb As Object, tr As Object, td As Object

Dim y As Long, z As Long, wb As Excel.Workbook, ws As Excel.Worksheet

Set wb = Excel.ActiveWorkbook
Set ws = wb.ActiveSheet

Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True

y = 1 'Column A in Excel
z = 1 'Row 1 in Excel

ie.navigate "http://", , , , "Content-Type: application/x-www-form-urlencoded" & vbCrLf

Do While ie.busy: DoEvents: Loop
Do While ie.ReadyState <> 4: DoEvents: Loop

Set doc = ie.document
Set hTable = doc.GetElementsByTagName("table")


For Each tb In hTable

Set hBody = tb.GetElementsByTagName("tbody")
For Each bb In hBody

Set hTR = bb.GetElementsByTagName("tr")
For Each tr In hTR


Set hTD = tr.GetElementsByTagName("td")
y = 1 ' Resets back to column A
For Each td In hTD
ws.Cells(z, y).Value = td.innertext
y = y + 1
Next td
DoEvents
z = z + 1
Next tr
Exit For
Next bb
Exit For
Next tb

End Sub