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
 
Sort by date Sort by votes

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
This works for 1 URL specified in the coding:
Code: 
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


    With CreateObject("msxml2.xmlhttp")
       .Open "GET", "http://greyhoundbet.racingpost.com/dog/blocks.sd?race_id=1593331&r_date=2018-03-01&dog_id=492435&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

But when I try to loop it it doesnt seem to work.
 
Upvote 0
So what's the difference between that url and the one you are calling in your loop?
 
Upvote 0
In the loop I have this:
Code: 
http://greyhoundbet.racingpost.com/dog/blocks.sd?race_id=" & raceId & "&r_date=" & dateId & "&dog_id=" & dogId & "blocks=details

As it changes doesn't it, so need the variances of raceid, dateid and now dogid?
 
Upvote 0
Yes, but that isn't the url you are calling in your loop in the code you posted, you were calling:
Rich (BB code): 
http://greyhoundbet.racingpost.com/card/blocks.sd?race_id=" & raceId & "&r_date=" & dateId & "&dog_id=" & dogId & "blocks=details
Not:
Rich (BB code): 
http://greyhoundbet.racingpost.com/dog/blocks.sd?race_id=" & raceId & "&r_date=" & dateId & "&dog_id=" & dogId & "blocks=details
 
Upvote 0
I tried changing that and still fails.

Do I need all the additional subs because I am pulling data here and not URLs?

I have tried this:

And this time is fails on the
Code: 
 Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(dogLinks), 17).Value2 = dogLinks

Fails with run-time error 13...So i think this is almost there?!

Indicating this line:
Code: 
.Open "GET", url, False
appears to be working


Code: 
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


    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
    
    getDogFormfromUrls = ret
    
End Function
 
Upvote 0
To try and loop this is causing issues...This code works for 1 URL:

As you can see the 1 URL is specified in the .Open GET line

Code: 
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


    With CreateObject("msxml2.xmlhttp")
       .Open "GET", "http://greyhoundbet.racingpost.com/dog/blocks.sd?race_id=1593331&r_date=2018-03-01&dog_id=492435&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


However, changing this to 'url' as below and trying and loop through all the URLs in the range (I2:I) is failing. This code that is failing is:

Code: 
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


    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
    
    getDogFormfromUrls = ret
    
End Function

Would really appreciate any help in just resolving this looping attempt.

Many thanks in advance.
 
Upvote 0
Which bit is failing? You need to be specific

The only difference between 1 and 2 is the url. Put a breakpoint in 2 and post the actual url you are calling
 
Last edited:
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
598
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,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

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