如何用VBA解析Yahoo Finance返回的JSON数据并提取至Excel单元格？

问题说明 #

尝试通过VBA从Yahoo Finance页面提取numberOfAnalystOpinions、targetMeanPrice等字段的raw值，但原代码的正则表达式无法成功解析，目标数据位于页面中一段以<script type="application/json" data-sveltekit-fetched data-url="https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?formatted=true&amp;modules=upgradeDowngradeHistory%2CrecommendationTrend%2Cfinanci开头的JSON块内。

原代码问题分析 #

1. 正则语法错误：VBA字符串中的双引号需要用两个双引号转义，原代码的正则Pattern里直接使用单个双引号，导致正则表达式无法正确识别。
2. 未定位目标JSON块：直接在整个HTML响应中搜索字段，容易匹配到无关内容，应该先提取出包含目标数据的script标签内的JSON文本，再进行字段提取。
3. 正则匹配逻辑宽泛：[\s\S]+?的匹配范围过大，可能跳过或错误匹配目标字段。

修正后的VBA代码 #

Sub SharePrices()
    Const Url As String = "https://finance.yahoo.com/quote/AAPL/analysis?p=AAPL"
    Dim sResp$, jsonText$
    Dim analystNum$, sHigh$, currentPrice$, sLow$, tMeanprice$
    
    ' 获取页面内容
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", Url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/88.0.4324.150 Safari/537.36"
        .send
        sResp = .responseText
    End With
    
    ' 第一步：提取目标script标签内的JSON文本
    With CreateObject("VBScript.RegExp")
        .Global = False
        .MultiLine = True
        .Pattern = "<script type=""application/json"" data-sveltekit-fetched data-url=""https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL[^""]*"">(.*?)</script>"
        If .Test(sResp) Then
            jsonText = .Execute(sResp)(0).SubMatches(0)
        End If
    End With
    
    ' 第二步：从JSON文本中提取目标字段的raw值
    If jsonText <> "" Then
        With CreateObject("VBScript.RegExp")
            .Global = False
            ' 提取numberOfAnalystOpinions的raw值
            .Pattern = """numberOfAnalystOpinions"":\{""raw"":(\d+),""fmt"""
            If .Test(jsonText) Then
                analystNum = .Execute(jsonText)(0).SubMatches(0)
            End If
            
            ' 提取targetMeanPrice的raw值
            .Pattern = """targetMeanPrice"":\{""raw"":([\d\.]+),""fmt"""
            If .Test(jsonText) Then
                tMeanprice = .Execute(jsonText)(0).SubMatches(0)
            End If
            
            ' 提取targetHighPrice的raw值
            .Pattern = """targetHighPrice"":\{""raw"":([\d\.]+),""fmt"""
            If .Test(jsonText) Then
                sHigh = .Execute(jsonText)(0).SubMatches(0)
            End If
            
            ' 提取targetLowPrice的raw值
            .Pattern = """targetLowPrice"":\{""raw"":([\d\.]+),""fmt"""
            If .Test(jsonText) Then
                sLow = .Execute(jsonText)(0).SubMatches(0)
            End If
            
            ' 提取currentPrice的raw值
            .Pattern = """currentPrice"":\{""raw"":([\d\.]+),""fmt"""
            If .Test(jsonText) Then
                currentPrice = .Execute(jsonText)(0).SubMatches(0)
            End If
        End With
    End If
    
    ' 写入Excel单元格
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Cells(ActiveCell.Row, ActiveCell.Column).Value = "Test"
    ws.Cells(ActiveCell.Row, ActiveCell.Column + 1).Value = analystNum
    ws.Cells(ActiveCell.Row, ActiveCell.Column + 2).Value = tMeanprice
    ws.Cells(ActiveCell.Row, ActiveCell.Column + 3).Value = sHigh
    ws.Cells(ActiveCell.Row, ActiveCell.Column + 4).Value = sLow
    ws.Cells(ActiveCell.Row, ActiveCell.Column + 5).Value = currentPrice
End Sub

关键修正点说明 #

• 转义双引号：在VBA字符串中，所有正则里的双引号都替换为两个双引号（""），确保正则语法正确。
• 定位目标JSON块：先通过正则提取出包含目标数据的script标签内容，缩小匹配范围，避免无关干扰。
• 精准匹配字段：针对每个字段的JSON结构，编写更精准的正则，直接匹配字段名后的raw值，避免宽泛匹配带来的错误。
• 优化单元格写入：直接通过单元格引用写入，避免频繁的Select操作，提升代码效率。

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