複数の検索結果をexcelに取り込む方法

質問

例えば、添付画像のようにexcelのあるシートのA列に検索ワードが書かれていて、それぞれの検索ワードでgoogle検索した結果(タイトル、URL)をexcelに取り込むにはどのようにしたらよいでしょうか？

・検索ワードは100個以内
・取得するgoogle検索結果は最初の1ページの10件
・取得する結果はシートを分けず、1枚のシートにまとめる

以上のようなことをしたいです。

少ししたいことと異なりますが、こちらの記事を試しに行ってみました。
しかし、「インデックスが有効範囲でありません」と表示されうまくいきませんでした。
http://yumem.cocolog-nifty.com/excelvba/2012/03/webgoogle-c0f1.html
行った方法
(visualBasicを開き、thisworkbookをダブルクリックーコードを貼り付けーexcelに戻り、マクロを実行）
環境：excel2007

excel初心者のわたしではまったくお手上げなので質問させていただきました。
先に記載したとおりのことをecxelでできないでしょうか？

回答No.1

real beatin（@realbeatin） · ベストアンサー

こんにちは。

リンク先のソースは、英数字の検索ワードによる検索専用です。
漢字やかな等は適切な文字に書換えた上で
URLを指定し直してあげないとなりません。
【urlエンコード】や【UTF-8 文字コード】等調べてみて下さい。

下記のスクリプトにコメントした
　▼検索結果以外のリンクを除外
　▼検索結果欄外にある文字列を見つけたら検索終了
この箇所は、日頃の管理の中で修正を加える部分です。
Googleがいつデザインを変更するか判りませんし、
私も過分なテストは出来ませんから、
例示された検索ワードで、今日、試したら
正しく機能することを確認できた、そこまではやりました、
ということです。
> excel初心者のわたしではまったくお手上げなので
　リンク先のスクリプトを動くように、
　望んだように編集を加えて、
という意味で、今回リンク先の趣旨を残して書き換えてお応えしますが、
ここに示すVBAを、編集・管理・メンテナンスするのは、
上級者に頼ることになるだろうこと、を理解しておいてください。
尚、Googleの利用規約については、そちらで確認して
余裕が出来た頃、Google API のことも知っておいてください。

Google索、という名前のマクロを実行することになります。
・検索ワードのシートを事前に選択しておく
・検索ワードはA列にある
・結果は新しいシート1枚に纏める
・取得するgoogle検索結果は最初の10件以下
・結果シート、A列は[検索ワード]
　B列は[タイトル]を表示したハイパーリンク、C列は[URL]
VisualBasicエディタを開き、"thisworkbookをダブルクリック"したら
Alt I M の順にタイプすると、標準モジュール[Module1]が挿入されるので
そこに下記のスクリプトを貼り付けてください。
頑張ってください。
' ' 〓　標準モジュール　〓
' ' // Google検索結果をWebクエリで取得
Sub Google索()
Const Start2 = 10　'Start2 = 取り出す結果数
Const Google = "https://www.google.co.jp/search?q="
Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, c As Range
Dim m, v, sWord As String, sURL As String, sName As String
Dim sh2Row As Long, tn As Long, cn As Long, i As Long, flg As Boolean
　m = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value　'　検索ワードを配列に取込む
　tn = UBound(m)　'　検索ワード総数
　Application.Cursor = xlWait　'　カーソル砂時計
　Application.ScreenUpdating = False
　Set sh2 = Sheets.Add(After:=ActiveSheet) '検索結果シート作成
　Cells(1, 1) = "検索ワード"
　Cells(1, 2) = "Title(リンク)"
　Cells(1, 3) = "URL"
　Set sh1 = Sheets.Add(After:=sh2) 'Webクエリシート追加

　For Each v In m　'　検索ワード総当たり
　　cn = cn + 1
　　If v <> "" Then
　　　sWord = Trim$(Replace(v, "　", " "))　'　検索ワードのスペース半角にしてトリミング
　　　Application.StatusBar = tn & "　件中　" & cn & "　件め　【" & sWord & "】　を検索中"　'　ステータスバー
　　　sh2.Cells(sh2Row + 1, "A") = sWord　'　検索ワードをA列に出力
　　　sURL = Google & EncodeUTF8(sWord)　'　GoogleSerach & 検索キーワードを★UTF-8にエンコード★した文字列
　　　'Webクエリ作 成
　　　With sh1.QueryTables.Add( _
　　　　Connection:="URL;" & sURL, _
　　　　Destination:=Range("A1"))
　　　　.WebSelectionType = xlEntirePage
　　　　.WebFormatting = xlWebFormattingAll
　　　　.BackgroundQuery = False
　　　　.Refresh
　　　End With
　　　'Webクエリからデータ取得
　　　Set rng = Range("A:A").Find("検索結果", , , xlWhole)
　　　Set rng = Range(rng(2, 1), Cells(Rows.Count, "A").End(xlUp))
　　　i = 0
　　　For Each c In rng
　　　　If c.Hyperlinks.Count Then
　　　　　If c(2, 1).Hyperlinks.Count = 0 And c(2, 1) <> "" Then
　　　　　　With c.Hyperlinks(1)
　　　　　　　flg = False　'　▼検索結果以外のリンクを除外
　　　　　　　flg = .Address Like Google & "*"　'　Google検索へのリンク除外
　　　　　　　flg = flg Or .Address Like "https://webcache*"　'　キャッシュへのリンク除外
　　　　　　　flg = flg Or .Address Like "http://webcache*"　'　キャッシュへのリンク除外
　　　　　　　flg = flg Or .Address Like "https://www.google.co.jp/maps*"　'　Mapへのリンク除外
　　　　　　End With
　　　　　　If Not flg Then
　　　　　　　sh2Row = sh2Row + 1
　　　　　　　c.Copy sh2.Cells(sh2Row, 2)
　　　　　　　sh2.Cells(sh2Row, 3) = c.Hyperlinks(1).Address
　　　　　　　i = i + 1
　　　　　　　If i = Start2 Then Exit For
　　　　　　End If
　　　　　End If
　　　　Else
　　　　　flg = False　'　▼検索結果欄外にある文字列を見つけたら検索終了
　　　　　flg = c Like "*関連する検索キーワード"
　　　　　flg = flg Or c Like "他の場所を探す"
　　　　　If flg Then Exit For　'　▲検索終了
　　　　End If
　　　Next
　　　sh1.QueryTables(1).Delete
　　　sh1.UsedRange.Clear
　　End If
　Next
　Application.DisplayAlerts = False
　sh1.Delete 'Webクエリシート削除
　Application.DisplayAlerts = True
　sh2.Select　' 検索結果シート表示
　sh2.Columns("A:C").AutoFit　' 列幅調整
　Application.StatusBar = ""　' ステータスバー元に戻す
　Application.Cursor = xlDefault　'　カーソル通常に戻す
　Application.ScreenUpdating = True
End Sub
' ' // URLエンコードした文字列（UTF-8）を返す関数
Private Function EncodeUTF8(ByVal Source As String) As String
　Dim oHtmlFile As Object
　Dim oElement As Object

　Source = Replace(Source, "\", "\\")
　Source = Replace(Source, "'", "\'")

　Set oHtmlFile = CreateObject("htmlfile")
　Set oElement = oHtmlFile.createElement("span")
　oElement.setAttribute "id", "rresponse"
　oHtmlFile.appendChild oElement
　oHtmlFile.parentWindow.execScript _
　　　　"document.getElementById('rresponse').innerText " _
　　　　& "= encodeURIComponent('" & Source & "');", "JScript"
　EncodeUTF8 = oElement.innerText
End Function

お礼

realbeatin様

まさにやりたいことができました！
ありがごうございます。
50個以上のキーワードになるとエラーになる時が時々がありますが、
これはパソコンが影響しているのかもしれません。
2回に分割するなどすれば対処できそうです。

本当に助かりました。重ね重ねありがとうございます。