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 insert name range Symbol.
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