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

问题描述

我是 VBA 的初学者。我想将雅虎财经中的“看跌期权数据”提取到 Excel 中。有人可以推荐一个 Excel VBA 脚本吗？

解决方法

您需要先下载一些模块才能开始。您需要从 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,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 的数量），因此雅虎期权数据并非万无一失。