使用VBA无法抓取React滚动加载网页表格数据问题求助

问题本质 #

你遇到的是虚拟滚动表格的加载逻辑：页面仅渲染当前可视区域附近的行，滚动时才会销毁不可见节点、加载新节点，因此直接抓取只能拿到当前已渲染的前几十条内容。

前置配置 #

在VBA编辑器中打开「工具」-「引用」，勾选以下两个库：

• Microsoft Internet Controls
• Microsoft HTML Object Library

将以下Sleep API声明放在代码模块的最顶部：

#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

完整修改后代码 #

Public Sub Scrape()
    Dim ie As InternetExplorerMedium: Set ie = New InternetExplorerMedium
    Dim html As HTMLDocument
    Dim dgBody As Object, mtbl As Object, source As Object
    Dim cRow As Long, lastSectionCount As Long, currentSectionCount As Long, noChangeTimes As Integer
    
    cRow = 1
    With ie
        .Visible = True
        .Navigate "http://testwebsite.com" '替换为实际目标网址
    End With
    
    '等待页面加载完成
    Do While ie.ReadyState <> READYSTATE_COMPLETE Or ie.Busy
        DoEvents
        Sleep 200
    Loop
    Set html = ie.Document
    '获取表格容器节点
    Set dgBody = html.querySelector(".tb-react-dg-body")
    lastSectionCount = 0
    noChangeTimes = 0
    
    '循环滚动触发加载，直到没有新内容加载
    Do
        currentSectionCount = html.getElementsByClassName("tb-react-dg-bsection").Length
        '判断是否有新节点加载
        If currentSectionCount = lastSectionCount Then
            noChangeTimes = noChangeTimes + 1
            If noChangeTimes >= 3 Then Exit Do '连续3次无新内容，判定已到列表底部
        Else
            noChangeTimes = 0
            lastSectionCount = currentSectionCount
        End If
        '滚动到表格最底部触发加载
        dgBody.scrollTop = dgBody.scrollHeight
        '等待加载完成
        Sleep 1000
        DoEvents
    Loop
    
    '全部加载完成后统一提取内容
    Set mtbl = html.getElementsByClassName("tb-react-dg-bcell")
    '如果需要按行4列存储，可以用下面的逻辑替换当前循环
    'For i = 0 To mtbl.Length - 1 Step 4
    '    Sheets(1).Cells(cRow, 1) = mtbl(i).textContent
    '    Sheets(1).Cells(cRow, 2) = mtbl(i+1).textContent
    '    Sheets(1).Cells(cRow, 3) = mtbl(i+2).textContent
    '    Sheets(1).Cells(cRow, 4) = mtbl(i+3).textContent
    '    cRow = cRow + 1
    'Next i
    For Each source In mtbl
        Sheets(1).Cells(cRow, 1) = source.textContent
        cRow = cRow + 1
    Next source
    
    ie.Quit
    Set ie = Nothing
    Set dgBody = Nothing
    Set html = Nothing
End Sub

备选滚动方案 #

如果上述滚动方式没有触发内容加载，可以将dgBody.scrollTop = dgBody.scrollHeight这一行替换为调用最后一行的scrollIntoView方法：

Dim allRows As Object
Set allRows = html.getElementsByClassName("tb-react-dg-brow")
If allRows.Length > 0 Then
    allRows(allRows.Length - 1).scrollIntoView False
End If

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