如何通过VBA在Excel中提取雅虎财经“看跌期权”？

Question

我是VBA初学者。我想将“Put Options Data”从 Yahoo Finance 提取到 Excel 中。谁能推荐一个 Excel VBA 脚本吗？

Answer 1

您需要先下载一些模块才能开始。您需要从 https://github.com/VBA-tools/VBA-JSON 下载 JSON 转换器，并将 .bas 文件导入到模块中。

然后您需要将以下代码复制到另一个模块中：

Function REGEX(strInput As String, matchPattern As String, Optional ByVal outputPattern As String = "$0") As Variant
    Dim inputRegexObj As New VBScript_RegExp_55.RegExp, outputRegexObj As New VBScript_RegExp_55.RegExp, outReplaceRegexObj As New VBScript_RegExp_55.RegExp
    Dim inputMatches As Object, replaceMatches As Object, replaceMatch As Object
    Dim replaceNumber As Integer

    With inputRegexObj
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = matchPattern
    End With
    With outputRegexObj
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\$(\d+)"
    End With
    With outReplaceRegexObj
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
    End With

    Set inputMatches = inputRegexObj.Execute(strInput)
    If inputMatches.Count = 0 Then
        REGEX = False
    Else
        Set replaceMatches = outputRegexObj.Execute(outputPattern)
        For Each replaceMatch In replaceMatches
            replaceNumber = replaceMatch.SubMatches(0)
            outReplaceRegexObj.Pattern = "\$" & replaceNumber

            If replaceNumber = 0 Then
                outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).value)
            Else
                If replaceNumber > inputMatches(0).SubMatches.Count Then
                    'regex = "A to high $ tag found. Largest allowed is $" & inputMatches(0).SubMatches.Count & "."
                    REGEX = CVErr(xlErrValue)
                    Exit Function
                Else
                    outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).SubMatches(replaceNumber - 1))
                End If
            End If
        Next
        REGEX = outputPattern
    End If
End Function

之后，您需要在“工具”-“参考”下勾选一些参考。下面是我目前已勾选的内容的屏幕截图，尽管我知道有很多内容您不需要。我确信您会想要以“Microsoft”开头的。

然后将以下代码复制到模块中：

Function GetOptions(ticker, sheetName As String)
    Dim XMLPage As New MSXML2.XMLHTTP60
    Dim HTMLDoc As New MSHTML.HTMLDocument
    Dim strPattern As String: strPattern = "root\.App\.main = ({.+}}}});"
    Dim JSON As Object
    Dim Key As Variant
    Dim i As Integer
    
    ' Stop the screen from updating
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
    XMLPage.Open "GET", "https://finance.yahoo.com/quote/" & ticker & "/options?p=" & ticker, False
    
    XMLPage.send

    Set JSON = JsonConverter.ParseJson(REGEX(XMLPage.responseText, strPattern, "$1"))
    
    sheets(sheetName).Select
    Cells.Select
    Selection.ClearContents
    
    On Error Resume Next
    
    ' Calls
    ' Create headers
    Cells(1, 1).value = "Calls"
    Cells(2, 1).value = "Contract Name"
    Cells(2, 2).value = "Last Trade Date"
    Cells(2, 3).value = "Strike"
    Cells(2, 4).value = "Last Price"
    Cells(2, 5).value = "Bid"
    Cells(2, 6).value = "Ask"
    Cells(2, 7).value = "Change (%)"
    Cells(2, 8).value = "Volume"
    Cells(2, 9).value = "Open Interest"
    Cells(2, 10).value = "Implied Volatility"

    i = 3
    
    ' Parse JSON
    For Each Key In JSON("context")("dispatcher")("stores")("OptionContractsStore")("contracts")("calls")
        Cells(i, 1).value = Key("contractSymbol")
        Cells(i, 2).value = Key("lastTradeDate")("fmt")
        Cells(i, 3).value = Key("strike")("raw")
        Cells(i, 4).value = Key("lastPrice")("raw")
        Cells(i, 5).value = Key("bid")("raw")
        Cells(i, 6).value = Key("ask")("raw")
        Cells(i, 7).value = Key("percentChange")("fmt")
        Cells(i, 8).value = Key("volume")("raw")
        Cells(i, 9).value = Key("openInterest")("raw")
        Cells(i, 10).value = Key("impliedVolatility")("fmt")
        i = i + 1
    Next Key
    
    i = i + 2
    
    ' Puts
    ' Create headers
    Cells(i - 1, 1).value = "Puts"
    Cells(i, 1).value = "Contract Name"
    Cells(i, 2).value = "Last Trade Date"
    Cells(i, 3).value = "Strike"
    Cells(i, 4).value = "Last Price"
    Cells(i, 5).value = "Bid"
    Cells(i, 6).value = "Ask"
    Cells(i, 7).value = "Change (%)"
    Cells(i, 8).value = "Volume"
    Cells(i, 9).value = "Open Interest"
    Cells(i, 10).value = "Implied Volatility"
    
    i = i + 1
    
    ' Parse JSON
    For Each Key In JSON("context")("dispatcher")("stores")("OptionContractsStore")("contracts")("puts")
        Cells(i, 1).value = Key("contractSymbol")
        Cells(i, 2).value = Key("lastTradeDate")("fmt")
        Cells(i, 3).value = Key("strike")("raw")
        Cells(i, 4).value = Key("lastPrice")("raw")
        Cells(i, 5).value = Key("bid")("raw")
        Cells(i, 6).value = Key("ask")("raw")
        Cells(i, 7).value = Key("percentChange")("fmt")
        Cells(i, 8).value = Key("volume")("raw")
        Cells(i, 9).value = Key("openInterest")("raw")
        Cells(i, 10).value = Key("impliedVolatility")("fmt")
        i = i + 1
    Next Key
    
    Application.Calculation = xlAutomatic

End Function

终于，我们到达了结局。现在，您有一个函数可以接收股票代码和要打印到的工作表。以下代码显示了整个程序的使用情况：

Sub OptionTest()
    Dim tick, shtName As String
    
    tick = "AAPL"
    shtName = "test"
    
    Call GetOptions(tick, shtName)

End Sub

我注意到缺少一条数据（AAPL210709P00146000 的数据量），因此雅虎选项数据并非绝对可靠。

Answer 2

我正在尝试在 Excel 上构建一个选项计算器，并尝试按照您的说明进行操作，但不断弹出错误“用户定义类型未定义”。我有机会得到你的帮助吗？