通过 Excel VBA 进行表格抓取

Question

尝试从网络上提取表格，我设法将表格复制并粘贴到 Excel 工作表上。但问题是它包含了我不想拥有的网页的更多数据。

如何将唯一的表格粘贴到工作表上，不包括任何其他数据。我希望有人能更好地解释这一点。

 Sub Web_Table()

    Dim HTMLDoc As New HTMLDocument
    Dim objTable As Object
    Dim lRow As Long
    Dim lngTable As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim ActRw As Long
    
    Dim objIE As InternetExplorer
    Set objIE = New InternetExplorer
    
    objIE.Navigate "https://www.eia.gov/dnav/pet/hist/LeafHandler.ashx?n=PET&s=EMD_EPD2DXL0_PTE_NUS_DPG&f=W"

    Do Until objIE.ReadyState = 4 And Not objIE.Busy
        DoEvents
    Loop
    
    Application.Wait (Now + TimeValue("0:00:03")) 'wait for java script to load
    HTMLDoc.body.innerHTML = objIE.Document.body.innerHTML
    
    With HTMLDoc.body
    
        Set objTable = .getElementsByTagName("table")
        For lngTable = 0 To objTable.Length - 1
            For lngRow = 0 To objTable(lngTable).Rows.Length - 1
            
                For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                    ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
                Next lngCol
            Next lngRow
            
            ActRw = ActRw + objTable(lngTable).Rows.Length + 1
        Next lngTable
        
    End With
    objIE.Quit
End Sub

Answer 1

我不确定您要保留哪个表，但假设您只想要第 8 个表（因为它有很多行），那么您可以通过它的索引 7 简单地引用它（因为它是基数 0)。

getElementsByTagName 方法返回一个元素集合（即使它只有一个结果），但您可以通过其索引将其缩小到特定元素。

修改你的代码如下：

    With HTMLDoc.body
    
        Set objTable = .getElementsByTagName("table")(7) 'Return only the 8th table from the collection
            For lngRow = 0 To objTable.Rows.Length - 1
                For lngCol = 0 To objTable.Rows(lngRow).Cells.Length - 1
                    ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable.Rows(lngRow).Cells(lngCol).innerText
                Next lngCol
            Next lngRow
                    
    End With

Answer 2

可以使用更快的 xhr 请求按其类选择大表（没有 JavaScript 渲染，id 不存在）。然后，您可以简单地使用剪贴板将表格传输到 Excel 工作表：

Option Explicit

Public Sub WriteOutTable()
    'required VBE (Alt+F11) > Tools > References > Microsoft HTML Object Library ;  Microsoft XML, v6 (your version may vary)

    Dim hTable As MSHTML.HTMLTable, clipboard As Object
    Dim xhr As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument
   
    Set xhr = New MSXML2.XMLHTTP60
    Set html = New MSHTML.HTMLDocument

    With xhr
        .Open "GET", "https://www.eia.gov/dnav/pet/hist/LeafHandler.ashx?n=PET&s=EMD_EPD2DXL0_PTE_NUS_DPG&f=W", False
        .send
        html.body.innerHTML = .responseText
    End With

    Set hTable = html.querySelector(".FloatTitle")
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    clipboard.SetText hTable.outerHTML
    clipboard.PutInClipboard
    ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).PasteSpecial
    
End Sub