Convert code from IE to XMLHTTP

[Sharid]

I have traditionally used IE for pulling data of the web, this is my code. I now want to change it to XMLHTTP as it tends to be faster, can some please help me make a few changes as I have made a few attempts but nothing works as i'm not 100% sure what I am doing. The code below works but is slow as it uses IE

Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wsSheet As Worksheet, links As Variant, IE As Object, link As Variant
Dim rw As Long
Dim dd As Variant

''''SHEET1 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("Sheet1")
    
''''Set IE = InternetExplorer
    Set IE = CreateObject("InternetExplorer.Application")
'''' Source sheet, URLS are in Sheet1 column A row2    
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)
    
    With IE
       .Visible = False
       
    For Each link In links
        .navigate (link)
    While .Busy Or .readyState <> 4: DoEvents: Wend
On Error Resume Next
    Set doc = IE.document
    
''''IF Statement, change class to suite needs ' Place DATA IN SHEET1 COLUMN B
    If doc.getElementsByClassName("mbg")(0) Is Nothing Then
           Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        dd = doc.getElementsByClassName("mbg")(0).Children(0).href
           Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
    End If
''''navigate links
      Next link     
''''Close IE Browser
    .Quit
End With
    Set IE = Nothing
End Sub

As always thanks in advance

 

[Sharid]

Every now and then when I run my code I get an error message

"runtime error 1004 : Method range of object - 'Global' failed"

If I try to debug the code, the worksheet shuts down. I have tried F8 an running through the code but nothing shows as a error, as the Error only happens every now and then.

Having Googled some answer, I think this MIGHT be the problem bit of the code

StartRow = wsSheet.Cells(wsSheet.Rows.Count, "B").End(xlUp).Row + 1
    EndRow = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = WorksheetFunction.Transpose(wsSheet.Range("A" & startrow & ":A" & EndRow))

Found on the net, Link 1, Link 2

Could someone please help me correct this. As I said the problem is hard to locate as it does not happen everytime, it every now and then and I can not debug the code as it shuts down excel.

 

[Dan_W]

Hi

What does the rest of the code look like? It's slightly odd that the whole spreadsheet shuts down. Can you please try adding/amending the following lines (full revised code below).

    Dim varLinks as Variant
    ....
    StartRow = wsSheet.Cells(wsSheet.Rows.Count, "B").End(xlUp).Row + 1
    EndRow = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    varLinks = Range("A" & startrow & ":A" & EndRow)
    links = WorksheetFunction.Transpose(varLinks)

Dim wb As Workbook
Dim wsSheet As Worksheet, links As Variant, link As Variant
Dim StartRow as Long
Dim EndRow as Long
Dim dd As Variant
Dim doc As HTMLDocument
Dim varLinks as Variant

''''SHEET1 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("test")
   
    StartRow = wsSheet.Cells(wsSheet.Rows.Count, "B").End(xlUp).Row + 1
    EndRow = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    varLinks = Range("A" & startrow & ":A" & EndRow)
    links = WorksheetFunction.Transpose(varLinks)

For Each link In links
    Set doc = NewHTMLDocument(CStr(link))

''''IF Statement, change class to suite needs ' Place DATA IN Sheet7 COLUMN B
    If doc.getElementsByClassName("mbg")(0) Is Nothing Then
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        dd = doc.getElementsByClassName("mbg")(0).Children(0).href
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
    End If

''''navigate links
     Next link
End Sub


Public Function NewHTMLDocument(strURL As String) As Object
    Dim objHTTP As Object, objHTML As Object, strTemp As String
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    objHTTP.Open "GET", strURL, False
    objHTTP.send
    If objHTTP.Status = 200 Then
        strTemp = objHTTP.responseText
    Set objHTML = CreateObject("htmlfile")
    objHTML.body.innerHTML = strTemp
    Set NewHTMLDocument = objHTML
Else
   'There has been an error
End If
End Function

 

[Dan_W]

Also, what are the values of startrow and endrow when it crashes? The error will likely arise when the end row turns out to be zero or something like that (ie: there are no entries in Row A).

 

[Sharid]

I keep getting a run time error message 13

Error code line

Also
I can get the "runtime error 1004 : Method range of object - 'WorkSheet' failed" at any point. If I start from the top (begining), then start row is always row2. I can have urls from row 2 to X and as soon as I click start I can get the RunTime Error 1004 message.

There are always entries in column A so if the start row was row X in column A, there are always entries below it. I have never run the code with 0 entries to process. As advised the error is every now and then and its a WorkSheet Fail not a Global Fail as I had originaly posted. When I try to debug excel shuts the sheet down and then restart.

It MAY JUST BE me, as I have had to stopped the code, using the Esc KEY a few times and the error from that action may NOT have cleared correct before I restarted the code. If you think your code is correct then the problem my be my actions and I may need help to create a Stop button, to end the code correct.


I have added an On time auto Save

Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:03:00"), "SaveThis"
End Sub

Module

Sub SaveThis()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True

Application.OnTime Now + TimeValue("00:03:00"), "SaveThis"
End Sub

 

[Dan_W]

HI - do you need to run the SaveThis sub every minute? If you want it to save all results, why not just run it the once at the end of the scraping sub?

 

[Dan_W]

Have you tried stepping through the code (F8 function key) - it would be useful to know what the StartRow and EndRow values are, and just to double check the varlinks variant to make sure it is, at least, capturing the URLs.

 

[Sharid]

The Save code was only introduced as the code would SOMETIMES crash, this way if it crashed then atleast I would have some saved work.

Also SOMETIMES I would get an error message "runtime error 1004 : Method range of object - 'WorkSheet' failed" and excel would shut down if I clicked on END or DEBUG.

Even without I get the "runtime error 1004 : Method range of object - 'WorkSheet' failed" message.

 

[Sharid]

I have done F8, the problem is the error only happens SOMETIMES so there is no guarantee that the error will show when I am doing F8, the error is a bit hit and miss.

Example

I have 100 urls, I run the code and then stop at the 30 url. When I restart the code, the "runtime error 1004 : Method range of object - 'WorkSheet' failed" error MAY or MANY NOT happen. It is a bit hit and miss. Sometimes the code will continue fine, othertimes the code give the runtime error message and crashes excel, closing it down.

ps I have been using the ESC key to stop the code, possibley this is the issue as it may NOT clear the error when the code is restarted. I possiblly need a stop button.

 

[Sharid]

Also I thing I need something like this added to bypass urls that are dead or need the security certificate OKAY to continue
Mr Excel Thread
If the website has an invalid security certificate or the url is DEAD then the code does not navigate to the next url, it waits for a user input of "YES".

If the certificate is invalid or url is DEAD then it should move to the next url, so if site has not loaded in X amount of time move to the next url.

 

[Dan_W]

Can you give an example of a dead URL pls.