web-dev-qa-db-ja.com

ExcelでVBAを使用してIEでGoogle検索し、最初の結果のハイパーリンクを返す

IE自動化を使用してExcelでテキストの文字列をGoogle検索します。Excelの別のセルにある最初の結果のWebサイトのハイパーリンクを返します。これは可能ですか？最初の結果でグーグル検索してウェブサイトのハイパーリンクを返すために必要な60,000レコードのリストがありますが、これに対して推奨される別のアプローチはありますか？事前に助けを感謝します。

excelvbamsxml
9
Collin Hendo

60,000レコードなので、IEを使用する代わりにxmlHTTPオブジェクトを使用することをお勧めします。
HTTPリクエストはより簡単で、はるかに高速です

サンプルファイルをダウンロード

Sub XMLHTTP()

    Dim url As String, lastRow As Long, i 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")


        For Each link In objH3

            If link.className = "r" Then

                Cells(i, 2) = link.innerText
                Cells(i, 3) = link.getelementsbytagname("a")(0).href
                DoEvents
            End If
        Next
    Next

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

    Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time) & " :minutes"
    MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub

CSS3セレクターの使用

 Sub XMLHTTP1()

        Dim url As String, i As Long, lastRow As Long
        Dim XMLHTTP As Object, html As New HTMLDocument, objResultDiv As HTMLAnchorElement


        lastRow = Range("A" & Rows.Count).End(xlUp).Row
        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 = New HTMLDocument
            html.body.innerHTML = XMLHTTP.ResponseText
            Set objResultDiv = html.querySelector("div#rso h3.r a")

            Cells(i, 2) = objResultDiv.innerText
            Cells(i, 3) = objResultDiv.href

            DoEvents
        Next

    End Sub

出力

enter image description here

HTH
サントシュ

19
Santosh

リンクは一貫してH3タグ内にあるようです。通常、次のようなものを使用して、ページが読み込まれるまでチェックします。

_Private Declare Sub Sleep Lib "kernel32" (ByVal nMilliseconds As Long)

Sub UseIE()
    Dim ie As Object
    Dim thePage As Object
    Dim strTextOfPage As String

    Set ie = CreateObject("InternetExplorer.Application")
    'ie.FullScreen = True
    With ie
        '.Visible = True
        .Navigate "http://www.bbc.co.uk"
        While Not .ReadyState = READYSTATE_COMPLETE '4
            Sleep 500      'wait 1/2 sec before trying again
        Wend
    End With

    Set thePage = ie.Document
    'more code here
End Sub
_

ただし、代わりに、getElementsByTagName("H3")を使用して最初のH3内のA要素を繰り返し参照し、これらの要素の最初の要素を取得してから、Aリンクとそのhref属性を探します。

JavaScriptでは、存在しない要素を参照しようとするとundefinedが返されますが、VBAからはエラー処理コードが必要になる可能性があります。

hrefを取得したら、ナビゲーションを停止するか（このためのコマンドが不明、おそらく_ie.Stop_）、すぐに次のページに移動します。

ただし、最初のリンクはスポンサーリンクであることが多く、返されるhrefは少し文字化けしています。これらのスポンサーリンクのテキストには、emタグが含まれているようです。この情報を使用して、これらのリンクを破棄し、ページのさらに下を見ます。

これを行うより良い方法があるかどうかはわかりません。

0
Andy G