more than maximum rows, fix scraper to save data to next worksheet

[blackhat7]

hi guys, i have this worksheet, and after scraping a lot of records

i can no longer scrape since it's giving me error, i want it to scrape and save the next records (after 1048576) to the next worksheet

Option Explicit

'EDIT FIRST AND LAST NUMBER TO SCRAPE HERE***************
Const FIRST_NUMBER As Long = 1048574
Const LAST_NUMBER As Long = 1060000
Const ENGLISH As Long = 0 '1 FOR ENGLISH, 0 FOR ARABIC NAME
'********************************************************

Sub READ_Company_Info_Sub()

Dim xml As MSXML2.XMLHTTP60, Json As Object, i, h, realFirstNum As Long, pctCompl As Long

'Show progress bar
UserForm1.Show vbModeless

'snippet to skip scraping first company
If FIRST_NUMBER = 1 Then
realFirstNum = 2
Else
realFirstNum = FIRST_NUMBER
End If

For i = realFirstNum To LAST_NUMBER 'loop from first company to last

Set xml = New MSXML2.XMLHTTP60

With xml

Dim myLink As String

If ENGLISH = 1 Then
myLink = "{'languageId':1,'languageCode':'en-GB','keywords':'" & i & "','method':'CI'}"
Else
myLink = "{'languageId':2,'languageCode':'ar-AE','keywords':'" & i & "','method':'CI'}"
End If

.Open "POST", "https://www.mohre.gov.ae/services/AjaxHandler.asmx/LoadServiceResult", False
.setRequestHeader "Content-type", "application/json; charset=UTF-8" 'if this is not set, it returns useless HTML code
.Send myLink 'send the actual request

If Len(xml.responseText) < 15 Then GoTo nextCompany: 'if returned data is empty just skip this one

Set Json = JsonConverter.ParseJson(xml.responseText) 'parse the data

If ENGLISH = 1 Then
For h = 1 To 13
Cells(i, h) = Json("d")(CStr(Cells(1, h))) 'for each column, header is equal to JSON's titles, scrape accordingly
Next h
Else
Cells(i, 14) = Json("d")("CompanyName") 'for each column, header is equal to JSON's titles, scrape accordingly
End If

End With
nextCompany:

'calculate the percentage for progress bar and send update
pctCompl = (100 * (i - realFirstNum)) / (LAST_NUMBER - realFirstNum)
progress pctCompl

Next i

End Sub

Sub progress(ByVal pctCompl As Long)

UserForm1.Text.Caption = pctCompl & "% Completed"
UserForm1.Bar.Width = pctCompl * 2

DoEvents

End Sub

 

[blackhat7]

bump

please help

 

[blackhat7]

hello world

 

[blackhat7]

hello? is anybody here?

 

[John_w]

Try this. Please use VBA code tags to preserve indentation of original code.

Option Explicit

'EDIT FIRST AND LAST NUMBER TO SCRAPE HERE***************
Const FIRST_NUMBER As Long = 1048574
Const LAST_NUMBER As Long = 1060000
Const ENGLISH As Long = 0 '1 FOR ENGLISH, 0 FOR ARABIC NAME
Const RECORDS_PER_SHEET As Long = 1048576
'********************************************************

Sub READ_Company_Info_Sub()

Dim xml As MSXML2.XMLHTTP60, Json As Object, i As Long, h As Long, realFirstNum As Long, pctCompl As Long
Dim r As Long

'Show progress bar
UserForm1.Show vbModeless

'snippet to skip scraping first company
If FIRST_NUMBER = 1 Then
realFirstNum = 2
Else
realFirstNum = FIRST_NUMBER
End If

For i = realFirstNum To LAST_NUMBER 'loop from first company to last

Set xml = New MSXML2.XMLHTTP60

With xml

Dim myLink As String

If ENGLISH = 1 Then
myLink = "{'languageId':1,'languageCode':'en-GB','keywords':'" & i & "','method':'CI'}"
Else
myLink = "{'languageId':2,'languageCode':'ar-AE','keywords':'" & i & "','method':'CI'}"
End If

.Open "POST", "https://www.mohre.gov.ae/services/AjaxHandler.asmx/LoadServiceResult", False
.setRequestHeader "Content-type", "application/json; charset=UTF-8" 'if this is not set, it returns useless HTML code
.Send myLink 'send the actual request

If Len(xml.responseText) < 15 Then GoTo nextCompany: 'if returned data is empty just skip this one

Set Json = JsonConverter.ParseJson(xml.responseText) 'parse the data

r = ((i - 1) Mod RECORDS_PER_SHEET) + 1

If ENGLISH = 1 Then
For h = 1 To 13
Cells(r, h) = Json("d")(CStr(Cells(1, h))) 'for each column, header is equal to JSON's titles, scrape accordingly
Next h
Else
Cells(r, 14) = Json("d")("CompanyName") 'for each column, header is equal to JSON's titles, scrape accordingly
End If

End With
nextCompany:

If i Mod RECORDS_PER_SHEET = 0 Then
    Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
End If

'calculate the percentage for progress bar and send update
pctCompl = (100 * (i - realFirstNum)) / (LAST_NUMBER - realFirstNum)
progress pctCompl

Next i

 

[Yongle]

Please use VBA code tags to preserve indentation of original code.

Could this be the reason why other members did not reply to your post ?