みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

複数の検索結果を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でできないでしょうか?

投稿日時 - 2017-05-24 15:00:07

QNo.9332915

困ってます

質問者が選んだベストアンサー

こんにちは。

リンク先のソースは、英数字の検索ワードによる検索専用です。
漢字やかな等は適切な文字に書換えた上で
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

投稿日時 - 2017-05-25 14:58:34

お礼

realbeatin様

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

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

投稿日時 - 2017-05-25 19:41:28

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問