Sub GetMarketData()
Dim myBrowser As Object, fs As Object, myExcel As Application, xlRange As Range
Dim myHtml As String, myFile As String, i As Long, j As Long, Data As Variant
On Error GoTo ErrHdl
Const myUrl = "http://www.cboe.com/DelayedQuote/QuoteTable.aspx"
Set myBrowser = CreateObject("InternetExplorer.Application")
myBrowser.Navigate myUrl
While myBrowser.Busy Or myBrowser.ReadyState <> READYSTATE_COMPLETE
DoEvents
Wend
With myBrowser.Document.All
On Error Resume Next
Do
.Item("ucQuoteTableCtl_txtSymbol").Value = Range("Ticker")
If Err.Number = 0 Then Exit Do
Err.Clear
DoEvents
Loop
.Item("ucQuoteTableCtl_optAll").Checked = True
.Item("ucQuoteTableCtl_btnSubmit").Click
End With
While myBrowser.Busy Or myBrowser.ReadyState <> READYSTATE_COMPLETE
DoEvents
Wend
myHtml = myBrowser.Document.body.innerHTML
myBrowser.Quit
Set fs = CreateObject("Scripting.FileSystemObject")
myFile = CurDir & "cboequote" & Format(Now, "mmddyyhhmmss") & ".html"
With fs
With fs.CreateTextFile(myFile, True, True)
.Write "<HTML>" & Chr(10) & myHtml & Chr(10) & "</HTML>"
.Close
End With
End With
Set myExcel = New Application
With myExcel.Workbooks.Open(myFile, 0, True)
Set xlRange = .ActiveSheet.Range("A3:AA1000").Find(What:="Last Sale", MatchCase:=False, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext)
If Not xlRange Is Nothing Then
myHtml = xlRange.Offset(-2, -1).Address
myHtml = xlRange.Offset(-2, -1).Value
myHtml = .ActiveSheet.Range(xlRange.Address).Offset(0, -2)
If UCase(Trim(xlRange.Offset(0, -1))) = "PUTS" Then Set xlRange = xlRange.Offset(0, -8)
Data = .ActiveSheet.Range(xlRange.Offset.End(xlToLeft).Offset(-2, 0), _
xlRange.End(xlToRight).End(xlDown).End(xlDown))
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2)
Cells(i + Range("Ticker").Row + 1, j + Range("Ticker").Column - 1) = Data(i, j)
Next j
Next i
Range(Cells(i + Range("Ticker").Row + 1, Range("Ticker").Column), Cells(Rows.Count, _
Range("Ticker").Column + j)).ClearContents
Else
MsgBox "Could not find data ...", vbCritical, "Get Data"
End If
.Close False
End With
myExcel.Quit
Columns.AutoFit
ErrHdl:
If Err.Number Then MsgBox "VBA Error " & Err.Number & ": " & Err.Description, vbCritical, "Get Data"
On Error Resume Next
Set myExcel = Nothing
fs.DeleteFile myFile, True
Set fs = Nothing
Set myBrowser = Nothing
End Sub
