Sub GetOptionChain()
Dim xlApp As Application, xlSht As Worksheet, xlRng As Range
Dim Symbol As String, TmpArr, Expiry As String, Calls(), Puts(), c As Long, p As Long
Dim i As Long, j As Long, BidCol As Integer, AskCol As Integer, Maturity As Date, Spot As Double
Dim StartRow As Long, ExpiryDate As Date
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")
StartRow = Range("StartRow").Row + 1
With Application
.ScreenUpdating = False
.EnableEvents = False
.StatusBar = "Retrieving Option Chain for " & Symbol & " ..."
End With
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
With Application
.Cursor = xlNorthwestArrow
MsgBox "The Symbol in cell " & Range("Symbol").Address(False, False) & " is invalid ...", _
vbExclamation, "Get Data"
.Cursor = xlDefault
End With
Else
TmpArr = Split(Replace(LCase(xlRng), "view by expiration:", ""), "|")
For i = 0 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
If LCase(Trim(xlRng.Offset(1, 0))) = "symbol" Then
BidCol = 0
AskCol = 0
ExpiryDate = ThirdFriday(CDate(Trim(TmpArr(i))))
For j = 1 To 10
If LCase(xlRng.Offset(1, j)) = "bid" Then
BidCol = j
ElseIf LCase(xlRng.Offset(1, j)) = "ask" Then
AskCol = j
End If
If BidCol > 0 And AskCol > 0 Then Exit For
Next j
If BidCol > 0 And AskCol > 0 Then
j = 2
Do While IsNumeric(xlRng.Offset(j, 7))
If Len(CStr(xlRng.Offset(j, 1))) = 0 Then Exit Do
If xlRng.Offset(j, 7) > 0 Then
c = c + 1
ReDim Preserve Calls(1 To 5, 1 To c)
Calls(1, c) = xlRng.Offset(j, 7)
Calls(2, c) = ExpiryDate
Calls(3, c) = xlRng.Offset(j, BidCol)
Calls(4, c) = xlRng.Offset(j, AskCol)
Calls(5, c) = xlRng.Offset(j, 1)
End If
j = j + 1
If j > Rows.Count Then Exit Do
Loop
End If
End If
End If
Set xlRng = xlSht.Cells.Find(What:="Puts", LookIn:=xlValues, Lookat:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not xlRng Is Nothing Then
If LCase(Trim(xlRng.Offset(1, 0))) = "symbol" Then
BidCol = 0
AskCol = 0
For j = 1 To 10
If LCase(xlRng.Offset(1, j)) = "bid" Then
BidCol = j
ElseIf LCase(xlRng.Offset(1, j)) = "ask" Then
AskCol = j
End If
If BidCol > 0 And AskCol > 0 Then Exit For
Next j
If BidCol > 0 And AskCol > 0 Then
j = 2
Do While IsNumeric(xlRng.Offset(j, -1))
If Len(CStr(xlRng.Offset(j, 1))) = 0 Then Exit Do
If xlRng.Offset(j, -1) > 0 Then
p = p + 1
ReDim Preserve Puts(1 To 5, 1 To p)
Puts(1, p) = xlRng.Offset(j, -1)
Puts(2, p) = ExpiryDate
Puts(3, p) = xlRng.Offset(j, BidCol)
Puts(4, p) = xlRng.Offset(j, AskCol)
Puts(5, p) = xlRng.Offset(j, 1)
End If
j = j + 1
If j > Rows.Count Then Exit Do
Loop
End If
End If
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
With Range("A" & StartRow - 3 & ":IV" & Rows.Count)
.Clear
.Interior.ColorIndex = 2
End With
If c > 0 Then
For i = 1 To UBound(Calls, 2)
For j = 1 To 5
Cells(i + StartRow - 1, j) = Calls(j, i)
Next j
Next i
End If
Cells(StartRow - 2, 1) = "CALLs"
Cells(StartRow - 1, 1) = "Strike"
Cells(StartRow - 1, 2) = "Maturity"
Cells(StartRow - 1, 3) = "Bid"
Cells(StartRow - 1, 4) = "Ask"
Cells(StartRow - 1, 5) = "Last"
If p > 0 Then
For i = 1 To UBound(Puts, 2)
For j = 1 To 5
Cells(i + StartRow - 1, j + 6) = Puts(j, i)
Next j
Next i
End If
Cells(StartRow - 2, 7) = "PUTs"
Cells(StartRow - 1, 7) = "Strike"
Cells(StartRow - 1, 8) = "Maturity"
Cells(StartRow - 1, 9) = "Bid"
Cells(StartRow - 1, 10) = "Ask"
Cells(StartRow - 1, 11) = "Last"
Range("Spot") = Spot
ErrHdl:
With Application
.StatusBar = False
.EnableEvents = True
End With
If Not xlApp Is Nothing Then
With xlApp
.CutCopyMode = False
.DisplayAlerts = False
While .Workbooks.Count
.ActiveWorkbook.Close False
Wend
.Quit
End With
Set xlApp = Nothing
End If
If Not xlSht Is Nothing Then Set xlSht = Nothing
If Not xlRng Is Nothing Then Set xlRng = Nothing
End Sub
Private Function ThirdFriday(Day As Date) As Date
'//Returns the thrid Friday of the month of the Day
Dim TmpDate As Date, Flag As Integer
TmpDate = CDate(Month(Day) & "/01/" & Year(Day))
Do
If Weekday(TmpDate) = vbFriday Then
Flag = Flag + 1
If Flag = 3 Then
ThirdFriday = TmpDate
Exit Do
End If
End If
TmpDate = TmpDate + 1
Loop
End Function
Private Sub ExtractData(xlSht As Worksheet, QueryString As String)
'//Web Query
With xlSht
With .QueryTables.Add(Connection:=QueryString, Destination:=.Range("A1"))
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.Refresh BackgroundQuery:=False
End With
End With
End Sub
