VBAでIEを起動してGoogle検索結果をセルに表示

最近副業を始めてみました。
スクレイピングの依頼が結構あったので、勉強がてら、
VBAでスクレイピングして、Excelに結果を表示するようなマクロを作ってみました。

参考にしたページ
[VBA]30分あればできるVBAスクレイピング

A列に検索したい検索ワードをいれ、
マクロを実行すると、
C列にキーワード、
D列に番号
E列にタイトル
F列にURL
が表示されるイメージです。

サンプルコード

Sample

Sub google検索結果をExcel出力()
    Dim objIE   As InternetExplorer 'IEオブジェクトを準備
    Dim strURL  As String

    Set objIE = CreateObject("Internetexplorer.Application")

    objIE.Visible = True 'IEを表示

    Dim i As Integer '検索ワードカウンタ
    Dim j As Integer '全検索結果カウンタ
    Dim seq As Integer '1検索ワードあたりの検索結果カウンタ

    i = 1
    j = 1

    検索結果クリア

    Do
        seq = 1
        strURL = "www.google.co.jp/search?q=" + Cells(i, 1).Value 'A列目に記載のキーワードをgoogle検索"

        Do
            objIE.navigate strURL
            Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE '読み込み待ち
                DoEvents
            Loop

            Dim htmlDoc As HTMLDocument  'HTMLドキュメントオブジェクトを準備
            Set htmlDoc = objIE.document 'objIEで読み込まれているHTMLドキュメントをセット

            Dim vResult As Variant
            vResult = ページ当たりの検索結果取得(htmlDoc, i, j, seq, 20)

            Dim strNextPageURL As String
            For Each aElement In htmlDoc.getElementsByClassName("pn")
                strURL = aElement.href '次へ
            Next
        Loop While seq < 20 'とりあえず1検索ワードあたり20件まで

        i = i + 1 '次の検索ワードへ

        Application.Wait [now()] + 3000 '待ちを入れる

    Loop While Cells(i, 1).Value <> ""

    objIE.Quit

End Sub

Sub 検索結果クリア()
    Dim i As Integer
    i = 1
    Do
        Cells(i, 3).Value = ""
        Cells(i, 4).Value = ""
        Cells(i, 5).Value = ""
        Cells(i, 6).Value = ""
        i = i + 1
    Loop While Cells(i, 1).Value <> ""
End Sub

Function ページ当たりの検索結果取得(ByVal htmlDoc As HTMLDocument, _
                                    ByVal i As Integer, _
                                    ByRef j As Integer, _
                                    ByRef seq As Integer, _
                                    ByVal limit As Integer)
    For Each htmlElement In htmlDoc.getElementsByClassName("r")
        For Each strTitle In htmlElement.getElementsByClassName("LC20lb")
            Cells(j, 3).Value = seq
            Cells(j, 4).Value = Cells(i, 1).Value
            Cells(j, 5).Value = strTitle.innerText

            Dim aElement As HTMLAnchorElement
            Set aElement = htmlElement.getElementsByTagName("a")(0)

            Dim hypLink As Hyperlink
            Set hypLink = Hyperlinks.Add(anchor:=Cells(j, 6), Address:=aElement.href)

            j = j + 1
            seq = seq + 1
            If seq > limit Then
                Exit Function
            End If
        Next
    Next htmlElement
End Function


Sub 検索結果クリア()
    Dim i As Integer
    i = 1
    Do
        Cells(i, 1).Value = ""
        Cells(i, 3).Value = ""
        Cells(i, 4).Value = ""
        Cells(i, 5).Value = ""
        Cells(i, 6).Value = ""
        i = i + 1
    Loop Cells(i, 1).Value <> ""
End Sub

Function ページ当たりの検索結果取得(ByVal htmlDoc As HTMLDocument, _
                                    ByVal i As Integer, _
                                    ByRef j As Integer, _
                                    ByRef seq As Integer _
                                    ByVal limit As Integer )
    For Each htmlElement In htmlDoc.getElementsByClassName("r")
        For Each strTitle In htmlElement.getElementsByClassName("LC20lb")
            Cells(j, 3).Value = seq
            Cells(j, 4).Value = Cells(i, 1).Value
            Cells(j, 5).Value = strTitle.innerText
            
            Dim aElement As HTMLAnchorElement
            Set aElement = htmlElement.getElementsByTagName("a")(0)
            
            Dim hypLink As Hyperlink
            Set hypLink = Hyperlinks.Add(anchor:=Cells(j, 6), Address:=aElement.href)
                            
            j = j + 1
            seq = seq + 1
            If seq > limit Then
                Exit Function
            End If
        Next
    Next htmlElement
End Function