Multithreading for Google Results VBA Code - excel

Question

For a university research project, I plan to run a larger number of data requests with a total of c. 3,000 different spreadsheets, each including about 800-1,000 unique data requests.
Aim of the code is to get the number of Google News results for certain search terms within specific time frames, as for instance the results for "Elon Musk" between 01/01/2015 and 12/31/2015.
I have so far constructed a code that works relatively well with a single-threaded approach but would, given the large number of data requests, take weeks for the 3,000 spreadsheets to be completed (Google is occasionally blocking the requests given the sheer number of search queries but this is something generally manageable).
On the other hand, I have read that there is not "native" option in VBA to go for a time saving multi-threading approach, while several suggestions exist to work around this lack of a real multi-threading function. None of them has however really worked for my case so far.
Is there any practicable option to have the code below send out several Google requests at a time? This would allow the data collection in a much shorter time span. As mentioned, I have already been through a number of complex "out of the box" multi-threading solutions, of which none really worked.
Option Explicit
Sub TermCheck()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
Dim start_time As Date
Dim end_time As Date
Dim var As String
Dim var1 As Object
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim cookie As String
Dim result_cookie As String
start_time = Time
Debug.Print "start_time:" & start_time
For i = 62 To lastRow
url = "https://www.google.com/search?q=" & Cells(i, 3) & "&source=lnt&tbs=cdr%3A1%2Ccd_min%3A" & Cells(i, 4) & "%2Ccd_max%3A" & Cells(i, 5) & "&tbm=nws"
Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.setRequestHeader "Content-Type", "text/xml"
XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
XMLHTTP.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.responseText
Set objResultDiv = html.getElementById("rso")
Set var1 = html.getElementById("resultStats")
If Not var1 Is Nothing Then
Cells(i, 6).Value = var1.innerText
End If
DoEvents
Next
end_time = Time
Debug.Print "end_time:" & end_time
Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub

Answer 1

I think you are on the right track by consolidating your data upfront, this is often a good idea for most projects. I'm not so sure you should give up on Async requests so quickly, have a go at this code below and see if that helps speed up your project.
I assumed that dates where in Columns D and E, so I mocked up my data to this idea. I also hard coded 'Elon Musk' in there to make things easier testing. You probably need to change this.
Option Explicit
Sub TermCheck(RunAsync As Boolean)
Const READYSTATE_COMPLETE As Long = 4
Dim url As String
Dim WebRequest As Object
Dim WebRequests As Object
Dim CellIndex As Variant
Dim Document As Object
Dim ResultStat As Object
Dim ws As Worksheet
Dim StartDate As Date
Dim EndDate As Date
Dim i As Long
StartDate = #1/1/2015#
EndDate = #1/2/2015#
Set ws = ThisWorkbook.Worksheets("Sheet3")
Set WebRequests = CreateObject("Scripting.Dictionary")
For i = 1 To 30
'Change URL here
url = "https://www.google.com/search?q=Elon%20Musk" & _
"&source=lnt&tbs=cdr%3A1%2Ccd_min%3A" & Replace(Format(ws.Cells(i, 4), "m/d/yyyy"), "/", "%2F") & _
"%2Ccd_max%3A" & Replace(Format(ws.Cells(i, 5), "m/d/yyyy"), "/", "%2F") & "&tbm=nws"
Set WebRequest = CreateObject("MSXML2.XMLHTTP")
With WebRequest
.Open "GET", url, RunAsync
.setRequestHeader "Content-Type", "text/xml"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
.send
End With
StartDate = DateAdd("d", 1, StartDate)
EndDate = DateAdd("d", 1, EndDate)
WebRequests.Add i, WebRequest
Next
For Each CellIndex In WebRequests.Keys
Set WebRequest = WebRequests(CellIndex)
While WebRequest.Readystate <> READYSTATE_COMPLETE: DoEvents: Wend
If WebRequest.Status = 200 Then
Set Document = CreateObject("htmlfile")
Document.body.innerhtml = WebRequest.ResponseText
Set ResultStat = Document.getElementById("resultStats")
'Missing equals sign was here
If Not ResultStat Is Nothing Then ws.Cells(CellIndex, 6).Value2 = ResultStat.innertext
End If
Next
End Sub
Sub TestRunRequests()
'Run it Synchronous
Application.ScreenUpdating = False
Dim MyTimer As Double
MyTimer = Timer
TermCheck False
Debug.Print "Synchronous took: " & Timer - MyTimer
'Run it Asynchronous
MyTimer = Timer
TermCheck True
Debug.Print "Asynchronous took: " & Timer - MyTimer
Application.ScreenUpdating = True
End Sub
Here are my the timings (in seconds) I got when I did 100 Requests for each method (async and sync):
Synchronous took: 44.5625
Asynchronous took: 22.46875

Answer 2

This may rather be the "pedestrian way" regarding a time saving approach but I decided to paste all relevant spreadsheets into one major Excel file. When amending the code to cover all spreadsheets simultaneously (and not only the active one), the search processes can literally be conducted in a fraction of the time otherwise required.