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

Question

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?

Answer 1

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.