VBA自动化谷歌搜索

Question

我使用下文提到的VBA脚本来自动谷歌搜索（要求的结果只有英文），但得到的错误91，PLZ建议solution.Other的要求是我需要非个性化的谷歌搜索结果

Sub XMLHTTP() 

    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 

    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 = 2 To lastRow 

     url = "https://www.google.com/webhp?hl=en&as_q=&as_epq=&as_oq=&as_eq=&as_nlo=&as_nhi=&lr=lang_en&cr=countryUS&as_qdr=all&as_sitesearch=&as_occt=any&safe=images&as_filetype=&as_rights=" & Cells(i, 1) & "&rnd=" & WorksheetFunction.RandBetween(1, 10000) 

     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 objH3 = objResultDiv.getelementsbytagname("H3")(0) 
     Set link = objH3.getelementsbytagname("a")(0) 


     str_text = Replace(link.innerHTML, "<EM>", "") 
     str_text = Replace(str_text, "</EM>", "") 

     Cells(i, 2) = str_text 
     Cells(i, 3) = link.href 
     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

问题就在这里：设置objResultDiv = html.getelementbyid（“RSO”）

如果没有“RSO” ID，objResultDiv将一无所有和代码稍后会失败，“运行时错误“ 91'：对象变量或块变量未设置“

（实际的错误将指向下一行，因为虽然objResultDiv是什么，不会发生错误，直到你尝试对其进行评估。）

所以，你需要问自己，我是什么真正需要的？避免RTE

一种方法是测试objResultDiv的价值：

Set html = CreateObject("htmlfile") 
html.body.innerHTML = XMLHTTP.ResponseText 
Set objResultDiv = html.getelementbyid("rso") 
If Not objResultDiv is Nothing then 
    Set objH3 = objResultDiv.getelementsbytagname("H3")(0) 
    Set link = objH3.getelementsbytagname("a")(0) 

    str_text = Replace(link.innerHTML, "<EM>", "") 
    str_text = Replace(str_text, "</EM>", "") 

    Cells(i, 2) = str_text 
    Cells(i, 3) = link.href 
End If 
DoEvents 

当然，这仅仅是推动这一问题的线进一步下跌：如果objResultDiv具有价值，但objH3不？然而，它指向了真正的解决方案：你想达到什么目的？当你实现它时，你期望看到什么？

不管怎么说，这就是为什么你所得到的RTE 91

至于非个性化的搜索，快速谷歌（具有讽刺意味真的）提示“的‘简单’谷歌的解决方法是键入& PWS = 0在搜索查询结束时，会关闭个性化，这种方法的缺点是费时，而且对于初学者来说，很难记住。“当然，如果您自动搜索，速度会更快。不知道这是否会奏效。

Answer 2

我不确定'英文'部分，但下面的脚本将循环遍历A列中使用的范围，从A2开始，下降。

Sub ImportWebData() 

j = 1 
Set IE = CreateObject("InternetExplorer.Application") 
IE.Visible = True 

With Sheets("Source") 

    RowCount = 2 
    Do While .Range("A" & RowCount) <> "" 
     CellName = .Range("A" & RowCount) 
     url = CellName 

     'get web page 
     IE.Navigate2 url 
     Do While IE.readyState <> 4 Or _ 
     IE.Busy = True 
     DoEvents 
     Loop 

     Set DestSh = ActiveWorkbook.Worksheets.Add 
     DestSh.Name = j 

      Sheets(j).Select 
      Cells.Select 
      Selection.Delete Shift:=xlUp 
      Range("A1").Select 
      With ActiveSheet.QueryTables.Add(Connection:= _ 
       "URL;" & CellName, Destination:=Range("$A$1")) 
       .Name = CellName 
       .FieldNames = True 
       .RowNumbers = False 
       .FillAdjacentFormulas = False 
       .PreserveFormatting = True 
       .RefreshOnFileOpen = False 
       .BackgroundQuery = True 
       .RefreshStyle = xlInsertDeleteCells 
       .SavePassword = False 
       .SaveData = True 
       .AdjustColumnWidth = True 
       .RefreshPeriod = 0 
       .WebSelectionType = xlEntirePage 
       .WebFormatting = xlWebFormattingNone 
       .WebPreFormattedTextToColumns = True 
       .WebConsecutiveDelimitersAsOne = True 
       .WebSingleBlockTextImport = False 
       .WebDisableDateRecognition = False 
       .WebDisableRedirections = False 
       .Refresh BackgroundQuery:=False 
      End With 

      j = j + 1 

    Sheets("Source").Select 
    RowCount = RowCount + 1 

    Loop 

End With 
IE.Quit 

End Sub 

下面的脚本将检查链接是否有效。

Option Explicit 

Sub CheckHyperlinks() 

    Dim oColumn As Range 
    Set oColumn = Column("A") ' replace this with code to get the relevant column 

    Dim oCell As Range 
    For Each oCell In oColumn.Cells 

     If oCell.Hyperlinks.Count > 0 Then 

      Dim oHyperlink As Hyperlink 
      Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1 hyperlink per cell 

      Dim strResult As String 
      strResult = GetResult(oHyperlink.Address) 

      oCell.Offset(0, 1).Value = strResult 

     End If 

    Next oCell 


End Sub 

Private Function GetResult(ByVal strUrl As String) As String 

    On Error GoTo ErrorHandler 

    Dim oHttp As New MSXML2.XMLHTTP30 

    oHttp.Open "HEAD", strUrl, False 
    oHttp.send 

    GetResult = oHttp.Status & " " & oHttp.statusText 

    Exit Function 

ErrorHandler: 
    GetResult = "Error: " & Err.Description 

End Function 

Private Function GetColumn() As Range 
    Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A") 
End Function