Как я могу использовать результаты поиска Google в Excel VBA?

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

Использование Google другими способами, кроме ручного просмотра страницы поиска, противоречит (в настоящее время) их Условиям обслуживания (выделено мной):

5.3. Вы соглашаетесь не осуществлять (или пытаться получить доступ) какие-либо Услуги. любым способом, кроме как через интерфейс, предоставленный Google, если вы не были специально разрешено делать это в отдельном Соглашение с Google. You конкретно согласен не получать доступ (или попытка доступа) к любому из Сервисов с помощью любых автоматизированных средств (в том числе использование скриптов или веб-сканеров) и убедитесь, что вы соблюдаете инструкции изложены в любом файле robots.txt файл присутствует на Сервисах.

Я знаю, что это не решает вашу непосредственную проблему.

Answer 2

Я предполагаю, что вы просто заинтересованы в различных способах выполнения задачи получения информации из Интернета в Excel. Не гугл специально. Один из таких способов размещен ниже. Однако, как я уже отмечал, существует риск нарушения TOS. Если вы используете приведенный ниже код, вы соглашаетесь принять на себя всю потенциальную ответственность / риск. Предоставленный код не предназначен для использования, но вы можете увидеть, как выполнить эту задачу на сайте, который вы имеете право использовать.

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