VBA - Pull Html, table data via

J

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
840
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
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Sort by date Sort by votes
3 of them for a range could be...

[TABLE="width: 484"]
<colgroup><col></colgroup><tbody>[TR]
[TD]http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=461748[/TD]
[/TR]
[TR]
[TD]http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=512446[/TD]
[/TR]
[TR]
[TD]http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=506030[/TD]
[/TR]
[TR]
[TD]http://greyhoundbet.racingpost.com/#dog/race_id=1593121&r_date=2018-02-28&dog_id=517731[/TD]
[/TR]
</tbody>[/TABLE]

Thanks.
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
No, as I explained in my post. I haven't got time to do the writing to the sheet or the looping for you
 
Upvote 0
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
VBA Code to Find Duplicate Values in a Range and Add a Number at the End
2
Replies
12
Views
664
OilEconomist
O
W
  • Solved
Looking For Tips To Improve My VBA
Replies
8
Views
198
who am i
W
G
  • Solved
Skip Row When Column Word Meet
2
Replies
14
Views
358
Peter_SSs
Peter_SSs
D
  • Question Question
Possible Use of CountIF and AVERAGE Functions
Replies
1
Views
130
Denny57
D
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
184
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,636
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top