vba 中的网页抓取 - 构造工作数据并从左到右单元格写入
刚刚在这里注册了一个帐户，是的，我是一个真正的菜鸟 - 请对我好一点。现在我面临的挑战是：我正在用 VBA 构建一个网络抓取工具，并找到了一个代码，我根据自己的需要做了一些修改。一切都很完美，而且实际上非常顺利。现在我希望加载到我的 exel 文档中的文本不要太长，而是很宽。我怀疑它与“.Offset（I，j）”有关。我玩过一点，但我只是设法毁了一切。这是我使用的代码：
Dim IE As InternetExplorer
Dim htmldoc As MSHTML.IHTMLDocument 'Document object
Dim eleColtr As MSHTML.IHTMLElementCollection 'Element collection for tr tags
Dim eleColtd As MSHTML.IHTMLElementCollection 'Element collection for td tags
Dim eleRow As MSHTML.IHTMLElement 'Row elements
Dim eleCol As MSHTML.IHTMLElement 'Column elements
Dim ieURL As String 'URL
'Open InternetExplorer
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
'Navigate to webpage
ieURL = "#"
IE.Navigate ieURL
'Wait
Do While IE.Busy Or IE.ReadyState <> 4
DoEvents
Loop
Set htmldoc = IE.Document 'Document webpage
Set eleColtr = htmldoc.getElementsByTagName("tr") 'Find all tr tags
'This section populates Excel
I = 0 'start with first value in tr collection
For Each eleRow In eleColtr 'for each element in the tr collection
Set eleColtd = htmldoc.getElementsByTagName("tr")(I).getElementsByTagName("td") 'get all the td elements in that specific tr
j = 0 'start with the first value in the td collection
For Each eleCol In eleColtd 'for each element in the td collection
Sheets("Sheet1").Range("A1").Offset(I, j).Value = eleCol.innerText 'paste the inner text of the td element, and offset at the same time
j = j + 1 'move to next element in td collection
Next eleCol 'rinse and repeat
I = I + 1 'move to next element in td collection
Next eleRow 'rinse and repeat
End Sub ```
一只萌萌小番薯1回答
-
慕村225694
你不需要浏览器。您可以使用更快的 xhr。抓取表格并循环行，然后循环填充预先确定大小的数组的列（请务必删除标题所在的行。它们可以被识别为[colspan='2']在第一个中具有td）。然后转置数组并写入工作表。Option ExplicitPublic Sub TransposeTable() Dim xhr As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument, table As MSHTML.htmltable 'required VBE (Alt+F11) > Tools > References > Microsoft HTML Object Library ; Microsoft XML, v6 (your version may vary) Set xhr = New MSXML2.XMLHTTP60 Set html = New MSHTML.HTMLDocument ' 7NXBG2 ; 8QT2E3 With xhr .Open "GET", "https://www.chrono24.com/watch/8QT2E3", False .send html.body.innerHTML = .responseText End With Set table = html.querySelector(".specifications table") Dim results(), rowCountToExclude As Long rowCountToExclude = html.querySelectorAll(".specifications table [colspan='2']").Length ReDim results(1 To table.rows.Length - rowCountToExclude, 1 To table.getElementsByTagName("tr")(0).Children(0).getAttribute("colspan")) Dim r As Long, c As Long, outputRow As Long, outputColumn As Long, html2 As MSHTML.HTMLDocument Set html2 = New MSHTML.HTMLDocument For r = 0 To table.getElementsByTagName("tr").Length - 1 Dim row As Object Set row = table.getElementsByTagName("tr")(r) html2.body.innerHTML = "<body> <table>" & row.outerHTML & "</table></body> " If html2.querySelectorAll("[colspan='2']").Length = 0 Then outputRow = outputRow + 1: outputColumn = 1 For c = 0 To row.getElementsByTagName("td").Length - 1 results(outputRow, outputColumn) = row.getElementsByTagName("td")(c).innerText outputColumn = outputColumn + 1 Next End If Set row = Nothing Next results = Application.Transpose(results) ActiveSheet.Cells(1, 1).Resize(UBound(results, 1), UBound(results, 2)) = resultsEnd Sub
随时随地看视频慕课网APP
相关分类
Html5