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

I am a beginner in VBA. I want to pull "Put Options Data" from Yahoo Finance into Excel. Can anybody recommend an Excel VBA script?

You will need to have some modules downloaded before you can start. You will need to download the JSON converter from https://github.com/VBA-tools/VBA-JSON and import the .bas file into a module.

Then you will need to copy the following code into another module:

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

Afterwhich, you'll need to check off some references under Tools - References. Below is a screenshot of what I currently have checked off, although I know there are many you won't need. I know for sure you'll want the ones that start with "Microsoft".

Then copy the following code into the module:

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

FINALLY, we arrive at the ending. You now have a function that takes in the ticker symbol and sheet that's being printed to. The following code shows the whole program being put to use:

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

End Sub

I noticed that there was a single piece of data missing (volume for AAPL210709P00146000), so the Yahoo options data isn't infallible.