Option Explicit
Public Sub Extract_Horse_Data()
Dim baseURL As String, horseURL As String
Dim webQuerySheet As Worksheet, horseDataSheet As Worksheet
Dim i As Integer
Dim horseQuery As QueryTable
Dim horseID As Long
Dim horseDataRow As Long
Debug.Print Now; "Started"
'Base URL with HorseID parameter omitted. The parameter name and value is appended to the web query when requesting
'each horse
baseURL = "http://www.digiturf.com/Betting/TransferHistory.asp"
'Sheet where web data for each horse is copied to
Set horseDataSheet = Worksheets("Sheet1")
'Sheet where web query is created
Set webQuerySheet = Worksheets("Sheet3")
'Set starting row on horse data sheet for copying horse web data to. If A1 is empty the sheet is cleared and initialised
'with column headers
With horseDataSheet
If .Range("A1").Value = "" Then
'Initialise horse data sheet with column headers in row 1, and set starting row to row 2
.UsedRange.ClearContents
.Range("A1").Resize(1, 11).Value = Array("URL", "Owner Name", "Date Joined", "Horse Name", _
"Gr", "Cl Ra", "Age", "Sex", "Colour", "Birthday", "Bought")
horseDataRow = 2
Else
'Set starting row to first empty row found in column A
horseDataRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End If
End With
'Delete all web queries on webQuerySheet
webQuerySheet.UsedRange.ClearContents
For i = webQuerySheet.QueryTables.Count To 1 Step -1
Debug.Print Now; "Deleting query table " & webQuerySheet.QueryTables(i).Name
webQuerySheet.QueryTables(i).Delete
Next
'Create the web query for retrieving horse data
Set horseQuery = Create_WebQuery(webQuerySheet)
If Not horseQuery Is Nothing Then
'Request web data for each HorseID, copying details to next row on horse data sheet
For horseID = 606000 To 606003
horseURL = baseURL & "?HorseID=" & horseID
Get_Horse_Data horseQuery, horseURL, horseDataSheet.Cells(horseDataRow, 1)
horseDataRow = horseDataRow + 1
Next
End If
Debug.Print Now; "Finished"
End Sub
Private Sub Get_Horse_Data(QT As QueryTable, sURL As String, copyToRange As Range)
'Request web data for a specific horse. If the horse exists its details are copied to the horse data sheet, otherwise
'blank details are copied
Dim savedErr As ErrObject
QT.Connection = "URL;" & sURL
On Error Resume Next 'Trap possible errors from refreshing web query
QT.Refresh BackgroundQuery:=False
If Err.Number = 0 Then
'No error occurred - copy data from retrieved web data to data sheet
On Error GoTo 0
Debug.Print Now; sURL & " - Retrieved OK"
With copyToRange
.Offset(0, 0) = sURL
'An owner name of "TRANSFER HISTORY" means the horse doesn't exist and all the details copied are blank
If QT.Destination.Range("A5").Value <> "TRANSFER HISTORY" Then
.Offset(0, 1) = QT.Destination.Range("A5").Value 'Owner name
End If
.Offset(0, 2) = QT.Destination.Range("D5").Value 'Date joined
.Offset(0, 3) = QT.Destination.Range("A8").Value 'Horse name
.Offset(0, 4) = QT.Destination.Range("D8").Value 'Gr
.Offset(0, 5) = QT.Destination.Range("G8").Value 'Cl Ra
.Offset(0, 6) = QT.Destination.Range("J8").Value 'Age
.Offset(0, 7) = QT.Destination.Range("M8").Value 'Sex
.Offset(0, 8) = QT.Destination.Range("N8").Value 'Colour
.Offset(0, 9) = QT.Destination.Range("O8").Value 'Birthday
.Offset(0, 10) = QT.Destination.Range("P8").Value 'Date bought
End With
Else
'An unexpected error occurred - tell the user
Set savedErr = Err
On Error GoTo 0
Debug.Print Now; sURL & " - Error " & savedErr.Number & " " & savedErr.Description
MsgBox "Weq query URL: " & sURL & vbNewLine & _
"Error number " & savedErr.Number & vbNewLine & _
savedErr.Description, , "Web query error"
End If
End Sub
Private Function Create_WebQuery(webQuerySheet As Worksheet) As QueryTable
'Create web query. Note that a URL is not specified in the Connection string, but instead is specified when querying
'each horse
Set Create_WebQuery = webQuerySheet.QueryTables.Add(Connection:="URL;", Destination:=webQuerySheet.Range("A1"))
If Not Create_WebQuery Is Nothing Then
With Create_WebQuery
.Name = "TransferHistory.asp"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False 'Wait for query to return before requesting next one (was True with Macro Recorder)
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
'.Refresh BackgroundQuery:=False 'Refresh when retrieving each URL, not here
End With
Else
MsgBox "Error creating web query" & vbNewLine & vbNewLine & _
"Error number = " & Err.Number & vbNewLine & Err.Description
End If
End Function
John I cannot thank you enough it works perfectly. I would never in a million years have been able to come up with this, so thank you again.
