VBA自动化谷歌搜索

Question

我正在使用下面提到的VBA脚本来自动化谷歌搜索(仅需要英文结果)，但收到错误91，请提出解决方案。其他要求是我需要非个性化的谷歌搜索结果

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

问题就在这里：Set objResultDiv = html.getelementbyid("rso")

如果没有 ">rso" id，objResultDiv 将为 Nothing，代码稍后将失败并显示"运行时错误'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