使用VBA爬取财报至Excel时首列重复显示的问题排查求助

这是一个用于从网页提取利润表至Excel的不成熟VBA版本，爬取生成的表格中首列内容在每行重复显示，推测该问题与网页表格的爬取逻辑相关，但无法定位具体问题。

原代码 #

Sub ScrapeMarketWatchgood()
    
    Dim xmlhttp As Object
    Dim htmlDoc As Object
    Dim tbl As Object
    Dim rowElement As Object
    Dim cellElement As Object
    Dim i As Integer
    Dim j As Integer
    Dim ws As Worksheet
    Dim cell As Range
    Dim ExcelTableObjectVariable As ListObject
   
    Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
    
    
    xmlhttp.Open "GET", "https://www.marketwatch.com/investing/stock/aapl/financials?mod=mw_quote_tab", False
    xmlhttp.setRequestHeader "Content-Type", "text/xml"
    xmlhttp.send ""

   
    Set htmlDoc = CreateObject("HTMLFile")
    htmlDoc.body.innerHTML = xmlhttp.responseText

    
    Set tbl = htmlDoc.querySelector("#maincontent > div.region.region--primary > div > div.element.element--table.table--fixed.financials > div > div > table")
    
  
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "Income Statement"

    i = 1

    
    For Each rowElement In tbl.getElementsByTagName("tr")
        j = 1
        For Each cellElement In rowElement.getElementsByTagName("td")
            ws.Cells(i, j).Value = cellElement.innerText
            j = j + 1
        Next cellElement
        i = i + 1 '
    Next rowElement

    
    Set xmlhttp = Nothing
    Set htmlDoc = Nothing
    Set ws = ThisWorkbook.Sheets("Income Statement")
    
    
    For Each cell In ws.Range("A1:F100").Cells
        If cell.WrapText Then
            cell.WrapText = False
        End If
    Next cell
     Set ws = ThisWorkbook.Worksheets("Income Statement")
     
    ws.Range("A1:F100").Columns.AutoFit
    ws.Range("A1:F100").Rows.AutoFit
    Set ExcelTableObjectVariable = ws.ListObjects.Add(xlSrcRange, ws.Range("A1:F100"), , xlYes)
End Sub

问题原因 #

原代码只遍历了表格行中的<td>元素，但MarketWatch的利润表结构中，每行的首列是<th>标签（用于定义行标题），并没有被纳入抓取范围。这会导致Excel表格的首列无法获取正确的行标题内容，反而因为部分行的<td>数量不足，出现内容错位或重复填充的情况。另外，请求头设置为text/xml是错误的，请求HTML页面时不需要该类型，可能影响响应解析。

修复后的代码 #

Sub ScrapeMarketWatchFixed()
    
    Dim xmlhttp As Object
    Dim htmlDoc As Object
    Dim tbl As Object
    Dim rowElement As Object
    Dim cellElement As Object
    Dim i As Integer
    Dim j As Integer
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim ExcelTableObjectVariable As ListObject
   
    Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
    
    ' 去掉错误的Content-Type请求头，请求HTML页面无需设置
    xmlhttp.Open "GET", "https://www.marketwatch.com/investing/stock/aapl/financials?mod=mw_quote_tab", False
    xmlhttp.send ""

    Set htmlDoc = CreateObject("HTMLFile")
    htmlDoc.body.innerHTML = xmlhttp.responseText

    ' 定位目标表格
    Set tbl = htmlDoc.querySelector("#maincontent > div.region.region--primary > div > div.element.element--table.table--fixed.financials > div > div > table")
    
    ' 创建新工作表
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "Income Statement"

    i = 1

    ' 同时遍历<th>和<td>元素，确保首列行标题被抓取
    For Each rowElement In tbl.getElementsByTagName("tr")
        j = 1
        For Each cellElement In rowElement.querySelectorAll("th, td")
            ws.Cells(i, j).Value = cellElement.innerText
            j = j + 1
        Next cellElement
        i = i + 1
    Next rowElement

    ' 清理对象
    Set xmlhttp = Nothing
    Set htmlDoc = Nothing
    
    ' 取消自动换行并自适应列宽行高（使用动态范围替代固定范围）
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).WrapText = False
    ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Columns.AutoFit
    ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Rows.AutoFit
    
    ' 转换为ListObject（使用动态范围）
    Set ExcelTableObjectVariable = ws.ListObjects.Add(xlSrcRange, ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)), , xlYes)
End Sub

关键修改点 #

1. 抓取范围修正：将rowElement.getElementsByTagName("td")改为rowElement.querySelectorAll("th, td")，同时获取首列的<th>行标题和其他列的<td>数据，解决首列内容缺失或重复的问题。
2. 请求头修正：移除错误的Content-Type: text/xml请求头，避免影响HTML响应的解析。
3. 动态范围替代固定范围：使用lastRow和lastCol获取表格实际边界，替代原代码中固定的A1:F100，避免处理无效单元格或遗漏数据。

内容的提问来源于stack exchange，提问作者philip