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 ': 개체 변수 또는 With 블록 변수가 설정되지 않았습니다. "

(실제 오류는 다음 행을 가리 킵니다. 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 

이 단지 문제가 더 아래 라인을 밀어 : 다음 RTE를 방지하기

한 가지 방법은 objResultDiv의 값을 테스트하는 것입니다 무엇 objResultDiv가 값을 가지고 있지만 objH3하지 않는 경우는? 그러나, 그것은 진정한 해결책을 지향합니다 : 당신은 무엇을 성취하려고합니까? 그리고 당신이 그것을 성취했을 때 당신은 무엇을 기대하고 있습니까? 가 아닌 맞춤 검색의 경우와 RTE 91

을 받고있는 이유

어쨌든, 즉, 빠른 구글이 (아이러니 정말) 제시는 " '단순한'구글 솔루션은 & PWS = 0을 입력하는 것입니다 검색 쿼리가 끝나면 개인 설정이 해제됩니다.이 방법은 시간이 많이 걸리고 초보자에게는 기억하기 어렵다는 단점이 있습니다. " 물론 검색을 자동화한다면 더 빠릅니다. 이것이 효과가 있을지는 모르겠다.

Answer 2

'영어'부분은 확실하지 않지만 아래 스크립트는 A2에서 시작하여 열 A의 사용 된 범위를 반복합니다.

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