Excel Google Results VBA代码的多线程处理

对于一个大学研究项目，我计划用c语言运行大量的数据请求。3000个不同的电子表格，每个表格包括大约800-1000个独特的数据请求

代码的目的是获取特定时间范围内特定搜索词的谷歌新闻结果数量，例如2015年1月1日至2015年12月31日之间的“Elon Musk”结果

到目前为止，我已经构建了一个代码，该代码在单线程方法中运行得相对较好，但由于数据请求数量巨大，3000个电子表格需要数周才能完成（考虑到搜索查询的数量，谷歌偶尔会阻止请求，但这通常是可以管理的）

另一方面，我读到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

---

这可能是一种节省时间的方法，但我决定将所有相关的电子表格粘贴到一个主要的Excel文件中。当修改代码以同时覆盖所有电子表格（而不仅仅是活动电子表格）时，搜索过程实际上可以在所需时间的一小部分内完成。

我认为，通过提前整合数据，您走上了正确的道路，这对于大多数项目来说通常是一个好主意。我不确定您是否应该如此迅速地放弃异步请求，看看下面的代码，看看这是否有助于加快您的项目

我假设日期在D列和E列中，所以我模拟了我的数据。我还硬编码了“Elon Musk”，使测试更容易。你可能需要改变这个

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

---

将代码迁移到VSA以加载项并利用.net framework是一种可能的VBA方法的选择，但如上所述，从.net迁移会容易得多。@sous2817感谢您的反馈。我已经检查了一个.NET解决方案，但它似乎相当复杂。是否有任何“简单”的方法来应用该方法？经验证的解决方案如何不适合您？VBA在单线程上运行，因此您能得到的最好的解决方案是面向对象的异步解决方案，它仍然是单线程的。如果您认为.NET解决方案是“复杂的”，那么任何VBA解决方案都将完全重新定义您对“复杂”的定义……感谢您的投入和努力。我已尝试应用您的版本，但没有收到任何结果（也在调整相应的电子表格名称、输入和输出单元格等时）。我想同时覆盖不同的电子表格似乎是目前最可行的解决方案。再次感谢您的努力，但我的表格仍然没有产生效果。我想我会继续开发/编辑我正在研究的方法。。。

Synchronous took: 44.5625
Asynchronous took: 22.46875