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

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
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
597
OilEconomist
O
G
  • Solved
Skip Row When Column Word Meet
2
Replies
14
Views
313
Peter_SSs
Peter_SSs
S
  • Question Question
VBA Code - Create Log sheet (Errorlog) in case VBA Macro condition is not met
Replies
1
Views
417
Tupe77
T
S
  • Question Question
Input Data Macro but I can't sum 3 cells from Sheet 1 before submitting to a cell in Sheet 2
Replies
3
Views
139
StephenCrump
S
S
  • Question Question
error on deleting last row
Replies
5
Views
308
Anthony47
A

Forum statistics

Threads
1,223,229
Messages
6,170,881
Members
452,364
Latest member
springate

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