Sub GetOptionChain()
Dim xlApp As Application, xlSht As Worksheet, xlRng As Range, DataCollection As Collection, Data, TmpArr
Dim Symbol As String, Expiry As String, c As Long, r As Long, m As Long, i As Long, Spot As Double
On Error GoTo ErrHdl
Set xlApp = New Application
Set xlSht = xlApp.Workbooks.Add.ActiveSheet
If xlApp.Calculation <> xlCalculationManual Then xlApp.Calculation = xlCalculationManual
Symbol = Range("Symbol").Text
ExtractData xlSht, "URL;http://finance.yahoo.com/q/os?s=" & Symbol
Set xlRng = xlSht.Cells.Find(What:="View By Expiration:", LookIn:=xlValues, Lookat:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If xlRng Is Nothing Then
Err.Raise vbObjectError + 513, , Symbol & "is an invalid symbol ..."
Else
Set DataCollection = New Collection
TmpArr = Split(Replace(LCase(xlRng), "view by expiration:", ""), "|")
Set xlRng = xlSht.Cells.Find(What:="Calls", LookIn:=xlValues, Lookat:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not xlRng Is Nothing Then
Data = xlRng.CurrentRegion
DataCollection.Add Data
End If
For i = 1 To UBound(TmpArr)
TmpArr(i) = "1 " & Trim(TmpArr(i))
If IsDate(TmpArr(i)) Then
Expiry = Format(CDate(TmpArr(i)), "YYYY") & "-" & Format(CDate(TmpArr(i)), "mm")
xlSht.Cells.Clear
ExtractData xlSht, "URL;http://finance.yahoo.com/q/os?s=" & Symbol & "&m=" & Expiry
Set xlRng = xlSht.Cells.Find(What:="Calls", LookIn:=xlValues, Lookat:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not xlRng Is Nothing Then
Data = xlRng.CurrentRegion
DataCollection.Add Data
End If
End If
Next i
Set xlRng = xlSht.Cells.Find(What:="(" & Symbol & ")", LookIn:=xlValues, Lookat:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not xlRng Is Nothing Then
TmpArr = Split(xlRng.Offset(0, 1), " ")
If UBound(TmpArr) > 3 Then Spot = TmpArr(3)
End If
End If
For i = 1 To DataCollection.Count
r = r + Ubound(DataCollection(i)) - 3
c = Ubound(DataCollection(i), 2) - 1
If c > m Then m = c
Next i
ReDim Finaldata(1 To r + 1, 1 To c)
r = 1
For c = 1 To Ubound(DataCollection(1), 2) - 1
FinalData(r, c) = DataCollection(1)(2, c)
Next c
Finaldata(1, 8) = "Strike"
For i = 1 To DataCollection.Count
For m = 3 To Ubound(DataCollection(i)) - 1
r = r + 1
For c = 1 To Ubound(DataCollection(i), 2) - 1
Finaldata(r, c) = DataCollection(i)(m, c)
Next c
Next m
Next i
Range("Symbol").Offset(0, 1) = Spot
Range(Range("Symbol").Offset(2, 0), Range("Symbol").Offset(
UBound(Finaldata) + 1, UBound(Finaldata, 2) - 1)) = Finaldata
Range(Range("Symbol").Offset(UBound(Finaldata) + 2, 0), _
Range("Symbol").Offset(UBound(Finaldata) + 2, UBound(Finaldata, 2))).ClearContents
Range(Range("Symbol").Offset(1, 0), Range("Symbol").Offset(1, UBound(Finaldata, 2) - 1)).ClearContents
ErrHdl: If Err.Number Then MsgBox Err.Description, vbCritical, "Get Option Chain"
On Error Resume Next
If Not xlApp Is Nothing Then
xlApp.CutCopyMode = False
xlApp.DisplayAlerts = False
xlApp.Quit
Set xlApp = Nothing
End If
If Not DataCollection Is Nothing Then Set DataCollection = Nothing
If Not xlSht Is Nothing Then Set xlSht = Nothing
If Not xlRng Is Nothing Then Set xlRng = Nothing
End Sub
Private Sub ExtractData(xlSht As Worksheet, QueryString As String)
With xlSht.QueryTables.Add(Connection:=QueryString, Destination:=xlSht.Range("A1"))
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.Refresh BackgroundQuery:=False
End With
End Sub
Yahoo
