Многопоточность для результатов Google Code VBA

Question

Для исследовательского проекта в университете я планирую выполнить большее количество запросов данных с общим значением c. 3000 различных электронных таблиц, каждая из которых включает около 800-1000 уникальных запросов данных.

Цель кода - получить количество результатов Новостей Google для определенных поисковых терминов за определенные промежутки времени, например, результаты для "Элон Маск" в период с 01.01.2015 по 12.12.2015.

Я до сих пор создал код, который относительно хорошо работает с однопоточным подходом, но, учитывая большое количество запросов данных, потребуется несколько недель для завершения 3000 электронных таблиц (Google иногда блокирует запросы, учитывая явный количество поисковых запросов, но это, как правило, управляемо).

С другой стороны, я читал, что в VBA нет «нативной» опции, позволяющей сэкономить время при многопоточности, хотя существует несколько предложений, позволяющих обойти это отсутствие реальной многопоточности. Ни один из них, однако, действительно не работал для моего случая до сих пор.

Есть ли практический вариант, чтобы приведенный ниже код отправлял несколько запросов Google одновременно? Это позволило бы сбор данных в гораздо более короткий промежуток времени. Как уже упоминалось, я уже прошел через ряд сложных «готовых» многопоточных решений, из которых ни одно на самом деле не работало.

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

Я думаю, что вы на правильном пути, консолидируя свои данные заранее, это часто хорошая идея для большинства проектов. Я не уверен, что вам следует так быстро отказываться от асинхронных запросов, изучить приведенный ниже код и посмотреть, поможет ли это ускорить ваш проект.

Я предположил, что даты в столбцах D и E, поэтому я смоделировал свои данные для этой идеи. Я также жестко запрограммировал «Элон Маск», чтобы облегчить тестирование. Вы, вероятно, должны изменить это.

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

Вот мои тайминги (в секундах), которые я получил, когда сделал 100 запросов для каждого метода (асинхронный и синхронный):

Synchronous took: 44.5625
Asynchronous took: 22.46875

Answer 2

Это может быть «пешеходный путь» в отношении подхода, позволяющего сэкономить время, но я решил вставить все соответствующие таблицы в один основной файл Excel. При внесении изменений в код для одновременного охвата всех электронных таблиц (и не только активной) процессы поиска могут буквально выполняться за долю времени, которое требуется в противном случае.