エクセルVBAで検索結果のリンク先URL取得について

Question

エクセルのたとえばA列にヤフーかグーグルで検索したい飲食店（値）の名前が1,000行入っています。
それを上から順番に検索していきます。この作業はloopやfor ~ nextで対応可能だと思います。問題はここからです。
その検索した文字を、ヤフーかグーグルで検索します。検索結果で、「ヤフーロコ」、「ホットペッパー」のリンク先URL、例えばURLに”loco.yahoo.co.jp/”や”hotpepper.jp/”が入っているもののみを、B列、C列に抽出します。もし、ヤフーロコやホットペッパーの両方に、該当の飲食店がなけれが、うち１つか、もしくは該当なしとして空白のまま、次の列に行き、また検索を続けていくというものです。
自動化処理は可能でしょうか。

WindFaller · Accepted Answer

こんばんは。

試しに、googleで調べてみました。
気になるレストラン名「ローターオクセン」（もうかつてのお店はなくなっていると思いつつ……）
を検索してみました。
「あった!」
　おまけに、”loco.yahoo.co.jp/”や”hotpepper.jp/”が入っているのでした。
これなら、できますね。（^^;　

VBA勉強中さんのVBAのお勉強のタシになるか分かりませんが、ちょっとコードを考えてみました。
実践的ではありませんし、雑な内容で、まだまだ修正の余地はありますが、基本的な考え方は分かっていただけるように思います。一応、検索は、1ページだけです。この辺りは、今のところ暗中模索です。

エラーを考慮していませんので、万が一には、ずれる可能性もありますので、検索値は、再び、セルに戻すようにしたほうがよいです。1,000件以上ですと、本当は、以下のようなコードはアクセス方法から変えないとダメだとは思いますが、当面のコードとしては、考え方は分かるはずです。

'//
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private objIE As InternetExplorer
''参照設定:Microsoft Internet Controls
Private Hpp As Boolean
Private Lya As Boolean
Sub MainAccess()
　Dim srcTxt As String
　Dim n As Variant
　Const BASE = "https://www.google.co.jp/"　'グーグル検索
　Cells(1, 1).Resize(, 5).Value = Array("店名", "loco.Yahoo", "URL1", "ホットペッパー", "URL2")
　Set objIE = New InternetExplorer
　With objIE
　　.Visible = True  ''安全だと分かったら、False　可
　　.Navigate2 BASE
　　Do While .Busy Or .ReadyState <> READYSTATE_COMPLETE
　　　DoEvents
　　Loop
　End With
　For Each n In Range("A2", Cells(Rows.Count, 1).End(xlUp))
　　ieSearch n.Value, objIE
　Next
　objIE.Quit
　Set objIE = Nothing
End Sub
Sub ieSearch(ByVal srcTxt As String, objIE As InternetExplorer)
　Dim srchBx As Object
　Dim srchBtn As Object
　Dim iSrc As Variant
　Dim v As Variant
　Dim buf As String
　Dim iHtml1 As String
　Dim iHtml2 As String
　Dim i As Long
　Lya = False: iHtml1 = ""
　Hpp = False: iHtml2 = ""
　With objIE
　　Set srchBx = .Document.getElementById("lst-ib")
　　srchBx.Value = srcTxt
　　srchBx.form.Submit
　　Sleep 1000 'ウェイトが重すぎるかも？しかし、抜けることもある
　　Do
　　　DoEvents
　　Loop Until .ReadyState = READYSTATE_COMPLETE
　　Set iSrc = .Document.getElementsByClassName("g")
　　If iSrc.Length > 0 Then
　　　For Each v In iSrc
　　　　If InStr(1, v.innerHTML, "loco.yahoo.co.jp", 1) > 0 Then
　　　　　Lya = True
　　　　　buf = Mid(v.innerHTML, InStr(1, v.innerHTML, "href=""", 1) + 6)
　　　　　iHtml1 = Left(buf, InStr(1, buf, " target", 1) - 2) & vbCrLf
　　　　End If
　　　　If InStr(1, v.innerHTML, "hotpepper.jp", 1) > 0 Then
　　　　　Hpp = True
　　　　　buf = Mid(v.innerHTML, InStr(1, v.innerHTML, "href=""", 1) + 6)
　　　　　iHtml2 = Left(buf, InStr(1, buf, " target", 1) - 2) & vbCrLf
　　　　End If
　　　　buf = ""
　　　Next
　　　i = Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　'Cells(i, 1).Value = srcTxt
　　　Cells(i, 2).Value = Lya
　　　Cells(i, 3).Value = iHtml1
　　　Cells(i, 4).Value = Hpp
　　　Cells(i, 5).Value = iHtml2
　　End If
　End With
End Sub

WindFaller · Answer

こんにちは。

>デバッグで
>iHtml2 = Left(buf, InStr(1, buf, " target", 1) - 2) & vbCrLf
>の部分が反転します。

実は、掲示内にアップするまで、最後の最後まで粘ったけれども、ここの部分は解決付かなかったのです。「想定内」とか言うつもりはないのですが、やはり「手抜きした所」が、もろに突かれてしまいました。（^^;

Sub MainAccess() がそのままでよいですが、次のieSearchというプロシージャは、入れ替えてください。もちろん、変更箇所を入れ替えてもよいです。ただし、まだ、エラーが出る可能性がなくなったわけではありません。On Error Resume のトラップを入れてもよいのですが、

　Set r = g.getElementsByClassName("r")
ここから、
　Set r_c = r(0).ChildNodes
この行に移行できる根拠などはありません。本来は、エラーチェックを入れればよいのですが、していません。たぶん、大丈夫だろうというところで進んでいます。(0)などが入る所は、本来みんな同じで、If r.Length >0 Then というチェックを入れないといけないのですが……。

>「プロシージャまたは引数が不正です」
これはよく分かりません。VBAのコードの問題のようですが……。
http://officetanaka.net/excel/vba/error/execution_error/error_5.htm
たぶん、ここと同じ話でしょうね。MidとInstr関数の組合せはやめましたから、大丈夫なはずです。

>私には難解でどこを調整したらよいのかが分かりません…。
最近、こういうのにはまっています。伝家の宝刀「FireBug」と、JavaScriptの書籍をみながらです。「FireBug」 の展開したリストから、探りを入れているというわけです。厳密には、こういうコードはVBAとも違うわけです。私も、きちんと本で勉強したらいいのですが、ナアナアなんです。

それらか、もう一つ、バグッぽい所に、
　　''Cells(i, 1).Value = srcTxt　'検索値
があるのは、この i は、ワークシート側と繋がっていないのです。
だから、本来は、ワークシートのセルの行数を、持ってきたほうがよいのですが、直せますか？

'//
Sub ieSearch(ByVal srcTxt As String, objIE As InternetExplorer)
　Dim srchBx As Object
　Dim srchBtn As Object
　Dim iSrc As Variant
　Dim buf As String
　Dim iHtml1 As String
　Dim iHtml2 As String
　Dim i As Long
　Dim g As Object ' HTMLLIElement
　Dim r, r_c
　Lya = False: iHtml1 = ""
　Hpp = False: iHtml2 = ""
　With objIE
　　Set srchBx = .Document.getElementById("lst-ib")
　　srchBx.Value = srcTxt
　　srchBx.form.Submit
　　Sleep 1000 'ウェイトが重すぎるかも、100でも可か？
　　Do
　　　DoEvents
　　Loop Until .ReadyState = READYSTATE_COMPLETE
　　Set iSrc = .Document.getElementsByClassName("g")
　　If iSrc.Length > 0 Then
　　　For Each g In iSrc
　　　　If InStr(1, g.innerHTML, "loco.yahoo.co.jp", 1) > 0 Then
　　　　　Lya = True
　　　　　Set r = g.getElementsByClassName("r")
　　　　　Set r_c = r(0).ChildNodes
　　　　　iHtml1 = r_c(0).href
　　　　End If
　　　　If InStr(1, g.innerHTML, "hotpepper.jp", 1) > 0 Then
　　　　　Hpp = True
　　　　　Set r = g.getElementsByClassName("r")
　　　　　Set r_c = r(0).ChildNodes
　　　　　iHtml2 = r_c(0).href
　　　　End If
　　　Next
　　　i = Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　''Cells(i, 1).Value = srcTxt　'検索値
　　　Cells(i, 2).Value = Lya
　　　Cells(i, 3).Value = iHtml1
　　　Cells(i, 4).Value = Hpp
　　　Cells(i, 5).Value = iHtml2
　　End If
End With
End Sub

エクセルVBAで検索結果のリンク先URL取得について

こんばんは。

こんにちは。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング