VBA IE Scrape data to excel

Hello,

Im running a project where VBA is reading values from a column A (Row by row) and with a web page request i want to return some data to excel.

A

WG550227465GR

WG550227***GR

This is automated with the below code

Code:

---

Sub Query()

      Dim x As Integer
      Dim i As Integer
      NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
      Range("A1").Select
        ' Establish "For" loop to loop "numrows" number of times.
        For x = 2 To NumRows + 1
        'If Len(Range("a" & x)) <> 13 Then
        'MsgBox "wrong tracking code"
        'Exit Sub
        'End If
      Dim Xrange As String
      Dim t As Integer
      Xrange = Trim(Range("A" & x).Value)
   
 Dim ie As New InternetExplorer
 t = 2


'web scrape + cell value
2    Application.wait (Now + TimeValue("0:00:002"))
        ie.navigate "https://www.elta-courier.gr/search?br=" & Xrange
        If Xrange = Mid(Xrange, 1, 2) = "pd" Then t = t - 2
        Do While ie.Busy Or ie.readyState <> 4: DoEvents: Loop 'Until ie.readyState = READYSTATE_COMPLETE
          Dim Doc As HTMLDocument
            Set Doc = ie.document
 
 
 Dim sDD As String
 Dim sDD1 As String
 Dim sDD2 As String
   
 'check if page has loaded with data, counting Elements number.
 i = Doc.getElementsByTagName("td").Length
 If i = 0 Then GoTo 2
 
 sDD = Trim(Doc.getElementsByTagName("TD")(t + 2).innerText)
 sDD1 = Trim(Doc.getElementsByTagName("TD")(t).innerText)
 sDD2 = Trim(Doc.getElementsByTagName("TD")(t + 1).innerText)
 
 ' write values to excel
 ie.Quit
 Dim aDD As Variant
 aDD = Split(sDD, ",")
 Range("C" & x).Value = aDD
 Range("D" & x).Value = sDD1
 Range("E" & x).Value = sDD2
 
1      Next
      Application.ScreenUpdating = True


ie.Quit
End Sub

---

Data requested to be returned is the second row from the attached picture.

Attachment 27881


PROBLEM
1) I get an error "The object invoked has disconected from its clients
2) It takes to long to read 500 records and parse and receive the data back to excel.

Can someone check what im doing wrong?

Try this code

Code:

---

Sub GetData_Test()
    GetData "WG550227465GR", "Sheet1", 1, 2
End Sub


Sub GetData(ByVal sID As String, ByVal wsName As String, ByVal lRow As Long, ByVal lCol As Long)
    Const sURL As String = "https://www.elta-courier.gr/track.php"
    Dim a, http As MSXML2.XMLHTTP60, col As Collection, json As Object, postData As String, sResp As String, i As Long
    Set http = New MSXML2.XMLHTTP60
    postData = "number=" & sID
    With http
        .Open "POST", sURL, False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send postData
        sResp = .responseText
    End With
    Set json = JSONConverter.ParseJson(sResp)
    Set col = json("result")(sID)("result")
    ReDim a(1 To col.Count, 1 To 1)
    For i = 1 To col.Count
        a(i, 1) = col.item(i)("status")
    Next i
    For i = LBound(a) To UBound(a)
        ThisWorkbook.Worksheets(wsName).Cells(i + lRow - 1, lCol).Value = a(i, 1)
    Next i
End Sub

---

The parameters used is the item you are dealing with and the sheet name where you would like to put the results and the row as the start row and finally the column as the start column.. In the example the results would be put in row 1 and column 2

By the way, download the JSONConverter.bas from this link
https://github.com/VBA-tools/VBA-JSO...nConverter.bas

Did the code help you?

Code is working perfect. One question though. Im not familiar with XML library and i modify your code to the following and im getting error : run-time error 10001 error parsing json

Code:

---

Sub GetData_Test()    GetData "sid", "Sheet1", 1, 2
   
End Sub




Sub GetData(ByVal sID As String, ByVal wsName As String, ByVal lRow As Long, ByVal lCol As Long)
    Const sURL As String = "https://www.elta-courier.gr/track.php"
      Dim x As Integer
     
      NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
      Range("A1").Select
        ' Establish "For" loop to loop "numrows" number of times.
        For x = 1 To NumRows        'If Len(Range("a" & x)) <> 13 Then
        'MsgBox "wrong tracking code"
        'Exit Sub
        'End If
        k = 1
      Dim Xrange As String
      Dim t As Integer
      sID = Trim(Range("A" & x).Value)
 


   
    Dim a, http As MSXML2.XMLHTTP60, col As Collection, json As Object, postData As String, sResp As String, i As Long
    Set http = New MSXML2.XMLHTTP60
    postData = "number=" & sID
    With http
        .Open "POST", sURL, False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send postData
        sResp = .responseText
    End With
    Set json = JsonConverter.ParseJson(sResp)
    Set col = json("result")(sID)("result")
    ReDim a(1 To col.Count, 1 To 1)
    For i = 1 To col.Count
        a(i, 1) = col.Item(i)("status")
    Next i
 
   
   
        ThisWorkbook.Worksheets(wsName).Cells(k + lRow - 1, lCol).Value = a(2, 1)
    lRow = lRow + 1
   
    Next x
End Sub

---

To explain further, i made a loop to read every row in column A (row by row) and in the array (a) retrieving only a(2) second record which is what i need.

Again thatnk you for you time and efford, your code is workind perfect.

Can you give snapshot of the worksheet ..?
Try to loop in the GetData_Test procedure not in the GetData Public Procedure.

In Column A there are almost 2000 records.

Will try now

Attachment 27885

Can you give two or three IDs so as to be able to test..? So you need just the second value of the results?!!

...And at this part im getting the json error



Attachment 27886

Quote:

---

Originally Posted by YasserKhalil

Can you give two or three IDs so as to be able to test..? So you need just the second value of the results?!!

---

Yes, just the second value only.

WG550227465GR

WG5502277**GR

Try this version

Code:

---

Sub GetData_Demo()
    Dim ws As Worksheet, r As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For r = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
        GetData ws.Cells(r, 1).Value, ws.Name, r, 2
    Next r
End Sub


Sub GetData(ByVal sID As String, ByVal wsName As String, ByVal lRow As Long, ByVal lCol As Long)
    Const sURL As String = "https://www.elta-courier.gr/track.php"
    Dim a, http As MSXML2.ServerXMLHTTP60, col As Collection, json As Object, postData As String, sResp As String, i As Long, cnt As Long
    Set http = New MSXML2.ServerXMLHTTP60
    postData = "number=" & sID
   
    With http
sPoint:
        .Open "POST", sURL, False
        .setRequestHeader "User-Agent", "Mozilla/5.0"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send postData
        .waitForResponse
        sResp = .responseText
        If InStr(sResp, "Fatal error") Then cnt = cnt + 1: Debug.Print "Wait .. " & cnt: GoTo sPoint
    End With
    Set json = JSONConverter.ParseJson(sResp)
    Set col = json("result")(sID)("result")
    ReDim a(1 To col.Count, 1 To 1)
    For i = 1 To col.Count
        a(i, 1) = col.item(i)("status")
    Next i
    ThisWorkbook.Worksheets(wsName).Cells(lRow, lCol).Value = a(2, 1)
End Sub

---

* I have updated the code as I noticed the site is down sometimes.

Unfortunately same error.


Attachment 27887

Yes. it worked like a charm, perfect. It worked perfectly !!

You're welcome. Glad I can offer some help.
Regards