使用VBA爬取Finviz筛选器数据的代码优化与问题咨询

优化后完整代码 #

Sub FetchTabularData()
    Const base$ = "https://finviz.com/"
    Dim Http As Object, Html As Object, ws As Worksheet
    Dim tabConfig, configItem, lastRow&, i&, ticker$, detailUrl$, S$
    Dim elem As Object, fieldElem As Object
    
    Set ws = ThisWorkbook.Worksheets("Data")
    Set Http = CreateObject("MSXML2.XMLHTTP")
    Set Html = CreateObject("HTMLFile")
    ws.Cells.Clear ' 清空原有数据
    
    ' 三个标签配置：数组元素依次为 标签URL、写入起始列、是否写入表头
    tabConfig = Array( _
        Array("https://finviz.com/screener.ashx?v=111", 1, True), _
        Array("https://finviz.com/screener.ashx?v=121", 13, False), _
        Array("https://finviz.com/screener.ashx?v=161", 23, False) _
    )
    
    ' 循环调用公共子过程爬取所有标签
    For Each configItem In tabConfig
        FetchSingleTab CStr(configItem(0)), CLng(configItem(1)), CBool(configItem(2)), Http, Html, ws, base
    Next configItem
    
    ' ---------------- 爬取详情页IPO Date和Cash/share ----------------
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' 写入两个新字段表头
    ws.Cells(1, 33) = "IPO Date"
    ws.Cells(1, 34) = "Cash/share"
    
    For i = 2 To lastRow
        ticker = ws.Cells(i, "A").Value
        If ticker = "" Then Exit For
        detailUrl = "https://finviz.com/quote.ashx?t=" & ticker
        
        ' 请求详情页
        With Http
            .Open "GET", detailUrl, 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
        Html.body.innerHTML = S
        
        ' 提取对应字段
        For Each elem In Html.getElementsByTagName("tr")
            If Not elem.Children(0) Is Nothing Then
                Select Case elem.Children(0).innerText
                    Case "IPO Date": ws.Cells(i, 33) = elem.Children(1).innerText
                    Case "Cash/sh": ws.Cells(i, 34) = elem.Children(1).innerText
                End Select
            End If
        Next elem
        ' 可选：加1秒等待避免反爬，需要的话取消下一行注释
        ' Application.Wait Now + TimeValue("00:00:01")
    Next i
    
    MsgBox "爬取完成！"
End Sub

' 单个标签爬取公共子过程
Sub FetchSingleTab(Url As String, startCol As Long, writeHeader As Boolean, Http As Object, Html As Object, ws As Worksheet, baseUrl As String)
    Dim S$, R&, elem As Object, oPage As Object, nextPage$, colOffset&
    R = 1
    While Url <> ""
        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
        Html.body.innerHTML = S
        
        ' 写入表头（仅首次调用时执行）
        If writeHeader And R = 1 Then
            For Each elem In Html.getElementById("screener-content").getElementsByTagName("tr")
                If elem.className = "table-header" Then
                    For colOffset = 0 To elem.Children.Length - 1
                        ws.Cells(1, startCol + colOffset) = elem.Children(colOffset).innerText
                    Next colOffset
                    Exit For
                End If
            Next elem
        End If
        
        ' 写入表格数据
        For Each elem In Html.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
                For colOffset = 0 To elem.Children.Length - 1
                    ws.Cells(R, startCol + colOffset) = elem.Children(colOffset).innerText
                Next colOffset
            End If
        Next elem
        
        ' 获取下一页地址
        Url = vbNullString
        For Each oPage In Html.getElementsByTagName("a")
            If InStr(oPage.className, "tab-link") And InStr(oPage.innerText, "next") > 0 Then
                nextPage = oPage.getAttribute("href")
                Url = baseUrl & Replace(nextPage, "about:", "")
            End If
        Next oPage
    Wend
End Sub

问题对应解决说明 #

• 代码重复问题：将重复的分页请求、表格解析逻辑封装为独立公共子过程，仅需传入标签配置参数即可完成多标签爬取，代码冗余度降低80%以上
• 表头无法写入问题：新增表头解析逻辑，自动定位筛选器表格表头行，直接提取列名写入Excel首行，无需手动硬编码列名
• 详情页字段获取问题：新增详情页爬取逻辑，遍历已爬取的股票代码构造详情页URL，匹配页面字段提取IPO Date和Cash/share写入表格

注：如果爬取股票数量较多，可开启代码中的等待逻辑，避免触发Finviz的反爬限制导致请求失败。

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