Ошибка при получении результата поиска в Google.

Question

Я новичок в VBA, и я решил, что попытка кодирования - лучший способ кодирования. Во всяком случае, я пытаюсь закодировать макрос, который получит первый URL-адрес результата поиска Google, но я получаю ошибку Object variable or With block variable not set, когда результат поиска равен 0, а остальные операции пропускаются. Вот изображение ошибка:

Вот код, который я использовал:

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.co.in/search?q=" & 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

Вот упрощенный код для того же метода.

Sub xmlHttp() 
    Dim url As String, 
     lastRow As Long, 
     XMLHTTP As Object, 
     html As Object, 
     objResultDiv As Object, 
     objH3 As Object, 
     link As Object 

    lastRow = Range("A" & Rows.Count).End(xlUp).Row 
    For i = 2 To lastRow 
     url = "https://www.google.co.in/search?q=" & Cells(i, 1) 
     Set xmlHttp = CreateObject("MSXML2.XMLHTTP") 
     xmlHttp.Open "GET", URL, False 
     xmlHttp.setRequestHeader "Content-Type", "text/xml" 
     xmlHttp.send 
     Set html = CreateObject("htmlfile") 
     html.body.innerHTML = xmlHttp.ResponseText 
     Set objResultDiv = html.getelementbyid("rso") 
     numb_H3 = objResultDiv.getElementsByTagName("H3").Length 
     If numb_H3 > 0 Then 
      Set objH3 = objResultDiv.getElementsByTagName("H3")(0) 
      Set link = objH3.getElementsByTagName("a")(0) 
      Range(i, 2) = link 
     Else 
     End If 
     DoEvents 
    Next 
End Sub 

Answer 2

Один простой способ обхода - хотя и не самый лучший - это пропустить ошибку.

Попробуйте следующее изменение:

start_time = Time 
Debug.Print "start_time:" & start_time 

On Error Resume Next '--Add this part. 
For i = 2 To lastRow 

Другие варианты включают правда обработки ошибок часть, то, что возвращает значение, когда ваш поиск ничего не возвращает.

Сообщите нам, если это поможет.

Answer 3

В нулевой результат случае Н3 пуст, так изменить код так, чтобы обработать этот случай

Set html = CreateObject("htmlfile") 
    html.body.innerhtml = XMLHTTP.ResponseText 
    Set objResultDiv = html.getelementbyid("rso") 

    **numb_H3 = objResultDiv.getElementsByTagName("H3").Length** 
    **If numb_H3 > 0 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 
    **Else** 
    **End If** 
    DoEvents 

Следующая