VBA - Pull Html, table data via

J

jamescooper

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

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
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.
 
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

S
  • Question
VBA Code - Create Log sheet (Errorlog) in case VBA Macro condition is not met
Replies
1
Views
134
Tupe77
T
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
184
ItalianPlatinum
I
U
  • Question
Information overwriting when transferring
Replies
7
Views
258
UTB
U
T
  • Question
Can this private sub code be transferred to a code without a given condition?
Replies
2
Views
253
TanjaU
T
L
  • Solved
VBA Error
2 3
Replies
29
Views
273
Joe4
Joe4

Forum statistics

Threads
1,214,979
Messages
6,122,551
Members
449,088
Latest member
davidcom

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