VbaFin.com

Visual Basic for Financial Professionals
   Home      Yahoo
This example retrieves option chain using the Refresh method of the QueryTable class of the Excel library. To use the macro you need to name 2 ranges: Symbol and Spot.

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