VBA - Pull Html, table data via

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771
Hello,

Is there any way to adapt my code below to not use Internet Explorer to grab all the data in the tables as below please?

Maybe using "msxml2.xmlhttp"

Many thanks.

Code:
Sub Form()
 
Dim objIE As InternetExplorer
Dim ele As Object
Dim y As Integer
Dim DLine As Range
    
    For Each DLine In Sheets("Sheet1").Range("B1:B1")
    Set objIE = CreateObject("InternetExplorer.Application")
    With objIE
    .Navigate DLine.Value
    .Visible = True
    Do While objIE.ReadyState <> READYSTATE_COMPLETE
    DoEvents
    Loop
    Application.Wait Now + TimeValue("00:00:02")
    End With
    
    For Each ele In objIE.Document.getElementById("sortableTable").getElementsByTagName("tr")
        Debug.Print ele.textContent
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 1)), 1, row + 1)
        Sheets("Dog Form").Cells(row, 1) = ele.Children(0).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 2)), 1, row)
        Sheets("Dog Form").Cells(row, 2) = ele.Children(1).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 3)), 1, row)
        Sheets("Dog Form").Cells(row, 3) = ele.Children(2).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 4)), 1, row)
        Sheets("Dog Form").Cells(row, 4) = ele.Children(3).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 5)), 1, row)
        Sheets("Dog Form").Cells(row, 5) = ele.Children(4).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 6)), 1, row)
        Sheets("Dog Form").Cells(row, 6) = ele.Children(5).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 7)), 1, row)
        Sheets("Dog Form").Cells(row, 7) = ele.Children(6).textContent
        row = row + 1


        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 8)), 1, row)
        Sheets("Dog Form").Cells(row, 8) = ele.Children(7).textContent
        row = row + 1
    
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 9)), 1, row)
        Sheets("Dog Form").Cells(row, 9) = ele.Children(8).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 10)), 1, row)
        Sheets("Dog Form").Cells(row, 10) = ele.Children(9).textContent
        row = row + 1


        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 11)), 1, row)
        Sheets("Dog Form").Cells(row, 11) = ele.Children(10).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 12)), 1, row)
        Sheets("Dog Form").Cells(row, 12) = ele.Children(11).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 13)), 1, row)
        Sheets("Dog Form").Cells(row, 13) = ele.Children(12).textContent
        row = row + 1


        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 14)), 1, row)
        Sheets("Dog Form").Cells(row, 14) = ele.Children(13).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 15)), 1, row)
        Sheets("Dog Form").Cells(row, 15) = ele.Children(14).textContent
        row = row + 1
        
        row = Cells(Rows.Count, "A").End(xlUp).row
        row = IIf(row = 1 And IsEmpty(Cells(1, 16)), 1, row)
        Sheets("Dog Form").Cells(row, 16) = ele.Children(15).textContent
        row = row + 1


    Next
      objIE.Quit
    Set objIE = Nothing
    
    Next DLine
 
End Sub
 

Some videos you may like

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771
3 of them for a range could be...

http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=461748
http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=512446
http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=506030
http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=517731

<colgroup><col></colgroup><tbody>
</tbody>

Thanks.
 

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771

ADVERTISEMENT

Forgot to add, could I also have the h1 in a column too from each sheet.
 

Kyle123

Well-known Member
Joined
Jan 24, 2012
Messages
2,708
This gets you the data for a given url, you'll need to adapt your links to the example in the sub test. You should see how it fits together, I don't have time to do this for you or make the code loop (or write it back to the sheet, but it's all the same as you already have):
Rich (BB code):
Sub test()
    Dim g
    g = getDogForm("http://greyhoundbet.racingpost.com/dog/blocks.sd?race_id=1592960&r_date=2018-02-27&dog_id=491247&blocks=details")
End Sub

Private Function getDogForm(ByVal url As String) As Variant

    Dim forms   As Collection
    Dim form    As Object
    Dim ret()   As Variant
    Dim x       As Long
    Dim details As Object
    Dim dogName As String
    
    With CreateObject("msxml2.xmlhttp")
       .Open "GET", url, False
       .send
       Set details = JSONConvert.ParseJson(.responsetext)("details")
    End With
    
    Set forms = details("forms")
    dogName = details("dogInfo")("dogName")
    
    ReDim ret(1 To forms.Count, 1 To 17)
        
    For Each form In forms
        x = x + 1
        ret(x, 1) = form("shortDate")
        ret(x, 2) = form("trackShortName")
        ret(x, 3) = form("distMetre")
        ret(x, 4) = "[" & form("trapNum") & "]"
        ret(x, 5) = form("secTimeS")
        ret(x, 6) = form("bndPos")
        ret(x, 7) = form("rOutcomeDesc")
        ret(x, 8) = form("rpDistDesc")
        ret(x, 9) = form("otherDTxt")
        ret(x, 10) = form("closeUpCmnt")
        ret(x, 11) = form("winnersTimeS")
        ret(x, 12) = form("goingType")
        ret(x, 13) = form("weight")
        ret(x, 14) = form("oddsDesc")
        ret(x, 15) = form("rGradeCde")
        ret(x, 16) = form("calcRTimeS")
        ret(x, 17) = dogName
    Next form
    
    getDogForm = ret
    
End Function

To make this work, you need an additional library, copy and paste the code from here:

https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas

Into a new module.

Remove the top line.

Name the module JSONConvert

Add a reference to Microsoft Scripting Runtime
 

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771

ADVERTISEMENT

Thanks, I have created a JSONConvert module and paste all that code in it.

It runs but nothing appears in the excel worksheet, have you specified the destination of the sheet it should go in there?

Thanks for you help.
 

Kyle123

Well-known Member
Joined
Jan 24, 2012
Messages
2,708
No, as I explained in my post. I haven't got time to do the writing to the sheet or the looping for you
 

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771
Hello,

Thanks - I have tried to adapt what was done. It works for 1 URL, but when I code it so a loop is in there it is failing at the following code line:

Code:
     Set details = JSONConvert.ParseJson(.responseText)("details")

Code:
Option Explicit


Private Enum URLPart
    race_id = 0
    date_id = 1
    dog_id = 2


End Enum


Sub test()


    Dim lastRow     As Long
    Dim x           As Long
    Dim urls        As Variant
    Dim dogLinks    As Variant
    
    lastRow = Sheets("Races").Range("I" & Rows.Count).End(xlUp).row
    urls = Sheets("Races").Range("I2:I" & lastRow).Value
    
    For x = LBound(urls) To UBound(urls)
        dogLinks = getDogForm(urls(x, 1))
        Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(dogLinks), 17).Value2 = dogLinks
    Next x


End Sub


Private Function getDogForm(ByVal url As String) As Variant


    Dim forms   As Collection
    Dim form    As Object
    Dim ret()   As Variant
    Dim x       As Long
    Dim details As Object
    Dim dogName As String
    Dim urlParts() As String
    Dim raceId As String
    Dim dateId As String
    Dim dogId As String
    
'http://greyhoundbet.racingpost.com/dog/blocks.sd?race_id=1593331&r_date=2018-03-01&dog_id=492435&blocks=details


    urlParts = getRaceIdAndDateFromUrl(url)
    
    raceId = urlParts(URLPart.race_id)
    dateId = urlParts(URLPart.date_id)
    dogId = urlParts(URLPart.dog_id)


    With CreateObject("msxml2.xmlhttp")
       .Open "GET", "http://greyhoundbet.racingpost.com/card/blocks.sd?race_id=" & raceId & "&r_date=" & dateId & "&dog_id=" & dogId & "blocks=details", False
       .send
       Set details = JSONConvert.ParseJson(.responseText)("details")
    End With
      
    Set forms = details("forms")
    dogName = details("dogInfo")("dogName")
    
    ReDim ret(1 To forms.Count, 1 To 17)
        
    For Each form In forms
        x = x + 1
        ret(x, 1) = form("shortDate")
        ret(x, 2) = form("trackShortName")
        ret(x, 3) = form("distMetre")
        ret(x, 4) = "[" & form("trapNum") & "]"
        ret(x, 5) = form("secTimeS")
        ret(x, 6) = form("bndPos")
        ret(x, 7) = form("rOutcomeDesc")
        ret(x, 8) = form("rpDistDesc")
        ret(x, 9) = form("otherDTxt")
        ret(x, 10) = form("closeUpCmnt")
        ret(x, 11) = form("winnersTimeS")
        ret(x, 12) = form("goingType")
        ret(x, 13) = form("weight")
        ret(x, 14) = form("oddsDesc")
        ret(x, 15) = form("rGradeCde")
        ret(x, 16) = form("calcRTimeS")
        ret(x, 17) = dogName
    Next form
    
    getDogForm = ret
    
End Function


Private Function formatLink(ByVal dogId As Long, ByVal raceId As String, ByVal dateId As String) As String


    formatLink = "http://greyhoundbet.racingpost.com/#dog/race_id=" & raceId & "&r_date=" & dateId & "&dog_id=" & dogId
    
End Function


Private Function getRaceIdAndDateFromUrl(ByVal url As String) As String()
    
    Dim ret(0 To 2) As String
    
    ret(0) = Split(Split(url, "race_id=")(1), "&")(0)
    ret(1) = Split(Split(url, "r_date=")(1), "&")(0)
    ret(2) = Split(Split(url, "dog_id=")(1), "&")(0)
    
    getRaceIdAndDateFromUrl = ret
    
End Function

Anyone have any ideas please?

Thanks.
 

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771
Not sure if anyone knows why, I am receiving "run-time error 424" Object required on that line above.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,304
Messages
5,527,903
Members
409,793
Latest member
shawnash

This Week's Hot Topics

Top