VBA自动化谷歌search
我正在使用下面提到的VBA脚本自动化谷歌search（只需要英文结果），但得到错误91，PLZbuild议解决scheme。其他要求是我需要非个性化的谷歌search结果
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 问题在这里：Set objResultDiv = html.getelementbyid（“rso”）
如果没有“ rso ”id，则objResultDiv将为Nothing，并且代码稍后将以“运行时错误91”失败：Object variable or With block variable not set“
（实际的错误将指向下一行，因为虽然objResultDiv是什么也没有，直到你尝试评估它，错误将不会发生。）
所以你需要问自己，我真的在找什么？
避免RTE的一种方法是testingobjResultDiv的值：
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没有？ 但是，它指出了真正的解决scheme：你想达到什么目的？ 当你达到目标时，你期望看到什么？
无论如何，这就是为什么你得到RTE 91。
至于非个性化的search，一个快速的谷歌（真正具有讽刺意味）build议：“'简单'谷歌的解决scheme是在search查询结束时input＆pws = 0，这将closures个性化。这种方法有时间的缺点而且对于初学者来说，很难记住。“ 当然，如果你自动search，速度会更快。 不知道这是否会奏效。
我对“英文”部分不太确定，但是下面的脚本将循环遍历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