如何通过 VBA 将 Yahoo Finance "Put Options" 拉入 Excel？

Question

我是 VBA 的初学者。我想从 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 = "[=10=]") 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, ""))
    
    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

终于，我们到了结局。您现在有一个函数，它接受股票代码和要打印到的 sheet 。以下代码显示了整个程序的使用：

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

End Sub

我注意到缺少一条数据（AAPL210709P00146000 的体积），因此 Yahoo 期权数据并非绝对可靠。

如何通过 VBA 将 Yahoo Finance "Put Options" 拉入 Excel？

How to pull Yahoo Finance "Put Options" in Excel by VBA?

excel

vba

yahoo-api

yahoo-finance