Private Sub horseWebQuery()
Dim ie As Object, Table As Object
Dim tblRow As Object, tblCell As Object
Dim strArr() As String, i As Long, j As Long, f As Long
Dim tmpArr() As Variant
If Not CBool(Len(Sheet1.Range("a2").Value)) Then _
Exit Sub
Application.StatusBar = "Please Wait: Retrieving Web Query Results..."
Application.ScreenUpdating = False
With Sheet1
Let tmpArr = .Range(.Range("a2"), _
.Range("A65536").End(xlUp).Item(2)).Value
End With
On Error GoTo errHandler
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate "http://www.drf.com/workoutHorseSearch.do"
Do While ie.busy: DoEvents: Loop
Do While ie.ReadyState <> 4: DoEvents: Loop
Sheet1.Range("b1:f1").Value = Array( _
"Horse Name", "Born", "Sex", "Sire", "Dam")
Sheet1.Range("B2:F65536").ClearContents
For f = LBound(tmpArr, 1) To UBound(tmpArr, 1)
If CBool(Len(tmpArr(f, 1))) Then
Let i = 0: Let j = 0
With ie
.document.Forms("HorseSearchForm").Name.Value = tmpArr(f, 1)
.navigate "JavaScript:if (fnValidate()) document.HorseSearchForm.submit();"
Do While .busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop
Set Table = .document.all.tags("table").Item(13)
ReDim strArr(1 To Table.Rows.Length - 2, 1 To 5)
For Each tblRow In Table.Rows
Let j = 1: Let i = i + 1
If i > 2 Then
For Each tblCell In tblRow.Cells
strArr(i - 2, j) = tblCell.innerText
Let j = j + 1
Next tblCell
End If
Next tblRow
End With
Sheet1.Range("b65536").End(xlUp).Item(2, 1).Resize( _
UBound(strArr, 1), 5).Value = strArr
End If
Next
With Sheet1
.Columns("B:F").AutoFit
.Columns("C:C").TextToColumns Destination:=.Range("C1"), _
DataType:=xlDelimited
End With
errHandler:
ie.Quit: Set ie = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox "Error: " & String$(2, vbLf) & _
Err.Number & String$(2, vbLf) & _
Err.Description
Err.Clear
End If
End Sub
