VBA爬取Finviz筛选器多标签数据无法提取表头问题咨询

解决思路 #

• 现有代码仅匹配了table-dark-row-cp和table-light-row-cp两类数据行，Finviz筛选结果的表头对应行类为table-header，新增对这类行的提取逻辑即可。
• 新增首页判断逻辑，仅在第一次请求页面时提取表头，避免翻页后重复写入表头。
• 表头的列偏移规则和数据行完全一致，提取后直接写入工作表第1行对应的起始列位置即可。

修改后完整代码 #

Public Sub Initial()
    FetchTabularData "https://finviz.com/screener.ashx?v=111", 1, 11, 0
    FetchTabularData "https://finviz.com/screener.ashx?v=121", 13, 10, 3
    FetchTabularData "https://finviz.com/screener.ashx?v=161", 23, 10, 3
End Sub

Public Sub FetchTabularData(ByVal Url As String, ByVal StartColumn As Long, AmountOfColumns As Long, ByVal StartChildren As Long)
    Const base$ = "https://finviz.com/"
    Dim elem As Object, S$, R&, oPage As Object, nextPage$
    Dim Http As Object, Html As Object, ws As Worksheet
    Dim isFirstPage As Boolean ' 新增首页标记

    Set ws = ThisWorkbook.Worksheets("Data")
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Set Html = CreateObject("HTMLFile")
 
    R = 1
    isFirstPage = True ' 初始为第一页

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Do While Url <> vbNullString
        DoEvents
        With Http
            .Open "GET", Url, False
            .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/85.0.4183.121 Safari/537.36"
            .send
            S = .responseText
        End With

        With Html
            .body.innerHTML = S
            ' 新增表头提取逻辑，仅首页处理
            If isFirstPage Then
                For Each elem In .getElementById("screener-content").getElementsByTagName("tr")
                    If InStr(elem.className, "table-header") > 0 Then
                        Dim HeaderRow() As Variant
                        ReDim HeaderRow(1 To 1, 1 To AmountOfColumns) As Variant
                        Dim i As Long
                        For i = 0 To AmountOfColumns - 1
                            HeaderRow(1, i + 1) = elem.Children(StartChildren + i).innerText
                        Next i
                        ws.Cells(1, StartColumn).Resize(ColumnSize:=AmountOfColumns).Value = HeaderRow
                        Exit For ' 找到表头就退出循环
                    End If
                Next elem
                isFirstPage = False ' 标记为非首页，后续翻页不再处理表头
            End If
            
            ' 原有数据行提取逻辑保持不变
            For Each elem In .getElementById("screener-content").getElementsByTagName("tr")
                If InStr(elem.className, "table-dark-row-cp") > 0 Or InStr(elem.className, "table-light-row-cp") > 0 Then
                    R = R + 1
                    Dim TempRow() As Variant
                    ReDim TempRow(1 To 1, 1 To AmountOfColumns) As Variant
                    Dim j As Long
                    For j = 0 To AmountOfColumns - 1
                        TempRow(1, j + 1) = elem.Children(StartChildren + j).innerText
                    Next j
                    ws.Cells(R + 1, StartColumn).Resize(ColumnSize:=AmountOfColumns).Value = TempRow ' 行号+1适配首行表头
                End If
            Next elem
            
            Url = vbNullString
            For Each oPage In .getElementsByTagName("a")
                If InStr(oPage.className, "tab-link") And InStr(oPage.innerText, "next") > 0 Then
                    nextPage = oPage.getAttribute("href")
                    Url = base & Replace(nextPage, "about:", "")
                End If
            Next oPage
        End With
    Loop

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

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