如何在Excel VBA中使用Google的搜索結果？

Question

我複製Google的搜索結果，並希望現在將其粘貼在Excel上。

我能夠把它寫到IE中搜索的地方，但不明白比它更多。

Sub get() 
With CreateObject("InternetExplorer.application") 
.Visible = True 
.navigate ("http://www.google.com/") 
While .Busy Or .readyState <> 4 
DoEvents 
Wend 
.document.all.q.Value = "keyword" 
.document.all.btnG.Click 
End With 
End Sub 

Answer 1

我會假設你只是想通過各種方式來完成從網上獲取信息到Excel中的任務。不專門Google。其中一種方式如下所示。不過，正如指出的那樣，至少有一種違反服務條款的風險。如果您使用下面的代碼，您同意接受所有潛在的責任/風險。提供的代碼不能用於使用，但您可以看到如何在您有權使用的網站上執行此任務。

Option Explicit 

Sub Example() 
    Dim strKeyword As String 
    Dim lngStartAt As Long 
    Dim lngResults As Long 
    Dim ws As Excel.Worksheet 
    On Error GoTo Err_Hnd 
    LockInterface True 
    lngStartAt = 1 
    lngResults = 100 
    strKeyword = "Google TOS" 
    Set ws = Excel.ActiveSheet 
    ws.UsedRange.Delete 
    With ws.QueryTables.Add("URL;http://www.google.com/search?q=" & strKeyword & "&num=100&start=" & lngStartAt & "&start=" & lngResults, ws.Cells(1, 1)) 
     .Name = "search?q=" & strKeyword 
     .WebSelectionType = xlEntirePage 
     .WebFormatting = xlWebFormattingNone 
     .WebPreFormattedTextToColumns = True 
     .WebConsecutiveDelimitersAsOne = True 
     .WebDisableDateRecognition = False 
     .Refresh False 
    End With 
    StripHeader ws 
    StripFooter ws 
    Normalize ws 
    Format ws 
Exit_Proc: 
    On Error Resume Next 
    LockInterface False 
    Exit Sub 
Err_Hnd: 
    MsgBox Err.Description, vbCritical, "Error: " & Err.Number 
    Resume Exit_Proc 
    Resume 
End Sub 

Private Sub StripHeader(ByRef ws As Excel.Worksheet) 
    Dim rngSrch As Excel.Range 
    Dim lngRow As Long 
    Set rngSrch = Intersect(ws.UsedRange, ws.Columns(1)) 
    lngRow = rngSrch.Find("Search Results", ws.Cells(1, 1), xlValues, xlWhole, _ 
     xlByColumns, xlNext, True, SearchFormat:=False).row 
    ws.Rows("1:" & CStr(lngRow + 1&)).Delete 
End Sub 

Private Sub StripFooter(ByRef ws As Excel.Worksheet) 
    Dim lngRowCount As Long 
    lngRowCount = ws.UsedRange.Rows.Count 
    ws.Rows(CStr(lngRowCount - 6&) & ":" & CStr(lngRowCount)).Delete 
End Sub 

Private Sub Normalize(ByRef ws As Excel.Worksheet) 
    Dim lngRowCount As Long 
    Dim lngRow As Long 
    Dim lngLastRow As Long 
    Dim lngDPos As Long 
    Dim strNum As String 
    lngRowCount = ws.UsedRange.Rows.Count 
    ws.Cells(1&, 2&).Value = ws.Cells(3&, 1&).Value 
    lngLastRow = 1& 
    For lngRow = 2& To lngRowCount 
     lngDPos = InStr(ws.Cells(lngRow, 1).Value, ".") 
     If lngDPos Then 
      If IsNumeric(Left$(ws.Cells(lngRow, 1).Value, lngDPos - 1&)) Then 
       ws.Cells(lngRow, 2&).Value = ws.Cells(lngRow + 2&, 1).Value 
       ws.Hyperlinks.Add ws.Cells(lngLastRow, 1&), "http://" & Left$(ws.Cells(lngRow - 2&, 1).Value, InStr(ws.Cells(lngRow - 2&, 1).Value, " ") - 1&) 
       lngLastRow = lngRow 
      End If 
     End If 
    Next 
    ws.Hyperlinks.Add ws.Cells(lngLastRow, 1&), "http://" & Left$(ws.Cells(lngRow - 1&, 1).Value, InStr(ws.Cells(lngRow - 2&, 1).Value, " ") - 1&) 
    For lngRow = lngRowCount To 1& Step -1& 
     If LenB(ws.Cells(lngRow, 2).Value) = 0& Then ws.Rows(lngRow).Delete 
    Next 
End Sub 

Private Sub Format(ByRef ws As Excel.Worksheet) 
    With ws.UsedRange 
     .ColumnWidth = 50 
     .WrapText = True 
     .Rows.AutoFit 
    End With 
    ws.Rows(1).Insert 
    ws.Cells(1, 1).Value = "Result" 
    ws.Cells(1, 2).Value = "Description" 
End Sub 

Public Sub LockInterface(ByVal lockOn As Boolean) 
    Dim blnVal As Boolean 
    Static blnOrgWIT As Boolean 
    With Excel.Application 
     If lockOn Then 
      blnVal = False 
      blnOrgWIT = .ShowWindowsInTaskbar 
      .ShowWindowsInTaskbar = False 
     Else 
      blnVal = True 
      .ShowWindowsInTaskbar = blnOrgWIT 
     End If 
     .DisplayAlerts = blnVal 
     .EnableEvents = blnVal 
     .ScreenUpdating = blnVal 
     .Cursor = IIf(blnVal, xlDefault, xlWait) 
     .EnableCancelKey = IIf(blnVal, xlInterrupt, xlErrorHandler) 
    End With 
End Sub 

另外，如果您想繼續使用機器人方法，請按照以下步驟操作。以前的注意事項適用於：

Sub RobotExample() 
    Dim ie As SHDocVw.InternetExplorer 'Requires reference to "Microsoft Internet Controls" 
    Dim strKeyword As String 
    Dim lngStartAt As Long 
    Dim lngResults As Long 
    Dim doc As MSHTML.HTMLDocument  'Requires reference to "Microsoft HTML Object Library" 
    Set ie = New SHDocVw.InternetExplorer 
    lngStartAt = 1 
    lngResults = 100 
    strKeyword = "Google TOS" 
    ie.navigate "http://www.google.com/search?q=" & strKeyword & _ 
     "&num=100&start=" & lngStartAt & "&start=" & lngResults 
    Do Until ie.readyState = READYSTATE_COMPLETE: DoEvents: Loop 
    Set doc = ie.document 
    MsgBox doc.body.innerText 
    ie.Quit 
End Sub 

Answer 2

使用谷歌通過其他方式比手動瀏覽到搜索頁面（目前）對他們Terms of Service（重點煤礦）：

5.3您同意不訪問（或試圖訪問）任何的服務 通過除谷歌提供的 接口以外的任何其他方式，除非您已經特別允許在與Google簽訂的單獨 協議中這樣做。 您 明確同意不訪問（或 試圖獲得）任何服務 通過任何自動方式（包括 使用腳本或網絡爬蟲）的和 應確保您遵守載於任何 說明robots.txt 文件出現在服務上。

我知道這不是解決您的直接問題。