Using VBA to copy data from Webpage table to excel

[New_Grasshopper]

I am trying to automate copying multiple tables of data from a web page to excel and found a soultion that worked for another user:
Trying to paste data from a website into excel into correct format (kudos to SundanceKid and Kokosek)

However when I try this for the website I am trying to copy from I get a Run-time error "91": Object variable or with Block variable not set when it reaches the step "For Each tr in Htable"....
When I check the locals window it appears that the hTable object is empty (it works fine when I try to replicate the datacapture from the webpage in the source post. The only changes to the original code is the web page string and the table name, I know the webpage string is correct because it loads when I paste the string into a browser but the site requires a log in so maybe this method wont work ? Alternatively I might have the table name wrong but I don't see how?

I have attached a pic of the target webpage showing the sourcecode and when I hover over the highligted line the table in the top window also gets highlighted.

My version of the code is:

Public Sub GetTable()
Dim html As MSHTML.HTMLDocument, hTable As Object, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set html = New MSHTML.HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "Search results", False
.send
html.body.innerHTML = .responseText
End With
Set hTable = html.getElementsByClassName("table table-striped sticky-enabled tableheader-processed sticky-table")(0)
Dim td As Object, tr As Object, th As Object, r As Long, c As Long, li As Object
For Each tr In hTable.getElementsByTagName("tr")
r = r + 1: c = 1
For Each th In tr.getElementsByTagName("th")
ws.Cells(r, c) = th.innerText
c = c + 1
Next
For Each td In tr.getElementsByTagName("td")
ball = 0
For Each li In td.getElementsByTagName("li")
ws.Cells(r, c + ball) = li.innerText
ball = ball + 1
Next
c = c + 1
Next
Next
End Sub

 

[Rijnsent]

You'll have to log in in your code. Right now you're getting the "not-logged in" page back (at least when I run your code locally I get that back). With VBA you could try to log in, but it might be a bit tricky / trial&error - these guys might have some useful code: GitHub - VBA-tools/VBA-Web: VBA-Web: Connect VBA, Excel, Access, and Office for Windows and Mac to web services and the web
Good luck

 

[New_Grasshopper]

You'll have to log in in your code. Right now you're getting the "not-logged in" page back (at least when I run your code locally I get that back). With VBA you could try to log in, but it might be a bit tricky / trial&error - these guys might have some useful code: GitHub - VBA-tools/VBA-Web: VBA-Web: Connect VBA, Excel, Access, and Office for Windows and Mac to web services and the web
Good luck

Hi - thanks for the suggestion but I found a different approach that I managed to get working, albeit it seems to fail occassionally when there are more than 300 pages in the result, I can live with that. I visited so many sites I can't recall where I found it (apologies to source) but here the code that is working for me:

Option Explicit

' VBE > Tools > References:
' Microsoft Internet Controls
Public Sub RetrieveInfo()
Dim IE As InternetExplorer, hTable As Object, clipboard As Object, t As Date
Dim no_of_pages As Long ' the number of pages in the search results
Dim i As Long ' for counting the page numbers as the loop executes
Dim search_string As String ' the 2nd part of the web address after a search is completed - because this might change depending on additional search parameters need to have it as a variable
Dim page_address As String ' the complete web address of the web page to be loaded
Dim paste_range As Integer ' the rownumber to paste the data to
Dim shp As Shape ' the table on the web page includes buttons I need to delete after copying

Const MAX_WAIT_SEC As Long = 5

Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Set IE = New InternetExplorer
'Application.ScreenUpdating = False
Sheets("temp1").Select 'I paste the entire web address after doing a serach for the data I want into cell K1 of this tab
no_of_pages = (Range("J1").Value) - 1 ' and enter the number of pages in the results into cell J1
search_string = Range("L1").Value ' L1 contains a formula that returns the text string in cell K1 minus the first 50 characters - this is then joined up 4 steps below
paste_range = 1 ' intial paste row
Sheets("temp").Select
For i = 0 To no_of_pages

page_address = "Search results" & i & search_string

With IE
.Visible = True
.Navigate2 page_address

While .Busy Or .ReadyState < 4: DoEvents: Wend

' this bit doesn't seem necessary because you have to log in to do the search to get the web address that paste in cell L1 and then you remain logged in for long enough to copy the pages
' With .Document
' .querySelector("#userId").Value = "your_username@domain.com"
' .querySelector("#password").Value = "yourpassword"
' .querySelector("form").submit
' End With

While .Busy Or .ReadyState < 4: DoEvents: Wend

t = Timer 'timed loop for details table to be present
Do
On Error Resume Next
Set hTable = IE.Document.querySelector("table.table.table-striped.sticky-enabled.tableheader-processed.sticky-table")
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While hTable Is Nothing
If Not hTable Is Nothing Then 'use clipboard to copy paste
clipboard.SetText hTable.outerHTML
clipboard.PutInClipboard
ThisWorkbook.Worksheets("temp").Range("A" & paste_range).PasteSpecial
Call ClearClipboard
'Loop through all the shapes and delete, the table contains hyperlink buttons that I don't want
On Error Resume Next
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
Columns("A:I").Select
Selection.UnMerge 'some rows/columns seem to be merged so need to unmerge them
Range("A1048576").Select
Selection.End(xlUp).Select
paste_range = ActiveCell.Row + 1
End If
End With
Next i
IE.Quit ' close instance of IE
Set IE = Nothing

' the remaining steps just move the data to another tab and tidy it up (remove blank rows, repeated headers etc)
Range("A1048576").Select
Selection.End(xlUp).Select
paste_range = ActiveCell.Row

Range("A1:I" & paste_range).Select
Selection.Cut
Sheets("temp1").Select
Range("A1048576").Select
Selection.End(xlUp).Select
paste_range = ActiveCell.Row + 1
Range("A" & paste_range).Select
ActiveSheet.Paste
Sheets("temp").Select
Range("A1").Select

Call tidy
'Application.ScreenUpdating = True
'MsgBox ("copying complete")
End Sub