EXCELVBAでYAHOOの検索結果をスクレイピングしたい

質問

特定のキーワードでyahoo検索を実行し
検索結果から、TITLE・description・URLを抜き取りたいのですが
もし、可能であれば、サンプルコードを記載頂けると幸いです。

宜しくお願いします。

回答No.2

KenKen_SP · ベストアンサー

基本的には IE を使うとか、createDocumentFromUrl などを使って
HtmlDocument を取得し、Html ソースのタグ、ID名、クラス名など
を手がかりとして解析することになると思います。

ですから、まずは目的ページの Html ソースをじっくり見ること
ですねー。

この方法での注意点は、汎用的なプログラムを書けないことです。
つまり、Web サイトで仕様変更（クラス名の変更等）がなされると、
プログラムも修正が必要になってしまうということですね。

Description の意味するところは、こういうこと？

って想像で書いたので意図通りでない場合はスルーして下さい。
検索結果を上位100件セルに書き出します。あまり考えず勢いだけで
書いてしまいましたので、必要なら適当に修正して下さい。

　# ところで...なぜ Yahoo なのでしょう？ Google の方が
　# 簡単な気がしますよ。

Sub sample()

　　Const ERR_DOCUMENT_EMPTY As Long = 1000

　　Dim sKeyword As String
　　Dim sQuery　 As String

　　' 検索キーワード問い合わせ＆検索URLを作成
　　sKeyword = InputBox("検索キーワードを入力")
　　If Len(sKeyword) = 0 Then
　　　　Exit Sub
　　Else
　　　　' Yahoo には 検索キーワードを URL エンコードして
　　　　' 送る必要があるみたい
　　　　sQuery = "ｈｔｔｐ：//search.yahoo.co.jp/search?"
　　　　sQuery = sQuery & "ei=UTF-8&"
　　　　sQuery = sQuery & "n=100&"　　　　 ' 検索数の設定
　　　　sQuery = sQuery & "p=" & UrlEncode(sKeyword)
　　　　sQuery = StrConv(sQuery, vbNarrow)
　　End If

　　On Error GoTo Err_

　　' URL から HTMLDocument を作成する
　　Dim doc1　　As MSHTML.HTMLDocument
　　Dim doc2　　As MSHTML.HTMLDocument
　　Set doc1 = New MSHTML.HTMLDocument
　　Set doc2 = doc1.createDocumentFromUrl(sQuery, vbNullString)

　　' ページの読み込み待機ほか
　　While LCase$(doc2.ReadyState) <> "complete"
　　　　DoEvents
　　Wend
　　If Len(doc2.body.innerText) = 0 Then
　　　　Err.Raise ERR_DOCUMENT_EMPTY, , "ページの読み込みに失敗" & vbNewLine & sQuery
　　End If

　　' 出力シート初期化
　　Application.ScreenUpdating = False

　　Dim sh　As Worksheet
　　Set sh = ActiveSheet
　　sh.Cells.Delete
　　sh.Range("A1:B1").Value = Array("Title", "Summary")
　　sh.Range("A:B").WrapText = True
　　sh.Range("A:A").ColumnWidth = 30
　　sh.Range("B:B").ColumnWidth = 50

　　' HtmlDocument の解析とセルへ出力
　　Dim div1　　 As MSHTML.HTMLDivElement
　　Dim div2　　 As MSHTML.HTMLDivElement
　　Dim div3　　 As MSHTML.HTMLDivElement
　　Dim sTitle　 As String
　　Dim sSummary As String
　　Dim sUrl　　 As String
　　Dim nRow　　 As Long

　　nRow = 2
　　For Each div1 In doc2.getElementsByTagName("DIV")
　　　　If div1.className Like "web" Then
　　　　　　sTitle = ""
　　　　　　sUrl = ""
　　　　　　sSummary = ""
　　　　　　For Each div2 In div1.getElementsByTagName("DIV")
　　　　　　　　Select Case div2.className
　　　　　　　　　　Case "hd"
　　　　　　　　　　　　With div2.getElementsByTagName("H3")(0)
　　　　　　　　　　　　　　sTitle = .innerText
　　　　　　　　　　　　　　sUrl = .getElementsByTagName("A")(0).href
　　　　　　　　　　　　　　sUrl = Mid$(sUrl, InStrRev(sUrl, "*-") + 2)
　　　　　　　　　　　　　　sUrl = Replace$(sUrl, "%3A", ":")
　　　　　　　　　　　　End With
　　　　　　　　　　Case "bd"
　　　　　　　　　　　　For Each div3 In div2.getElementsByTagName("DIV")
　　　　　　　　　　　　　　If div3.className = "abs" Then
　　　　　　　　　　　　　　　　sSummary = div3.innerText
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　End Select
　　　　　　Next
　　　　　　sh.Hyperlinks.Add Anchor:=sh.Cells(nRow, 1), _
　　　　　　　　　　　　　　　　　　　Address:=sUrl, _
　　　　　　　　　　　　　　　　　　　TextToDisplay:=sTitle
　　　　　　sh.Cells(nRow, 2).Value = sSummary
　　　　　　nRow = nRow + 1
　　　　End If
　　Next
　　sh.Cells.EntireRow.AutoFit

Bye_:
　　Set doc2 = Nothing
　　Set doc1 = Nothing
　　Set sh = Nothing
　　Exit Sub
Err_:
　　MsgBox Err.Description, vbCritical
　　Resume Bye_
End Sub

' // URL エンコード
'
Public Function UrlEncode(ByVal srcText As String) As String

　　If Len(srcText) Then
　　　　With CreateObject("ScriptControl")
　　　　　　.Language = "JScript"
　　　　　　UrlEncode = .CodeObject.encodeURI(srcText)
　　　　End With
　　End If

End Function

回答No.5

KenKen_SP

...なぜか悪者にされてる気がしますが。

#2 は回答が無い時点で書いたものですから、レスの流れまで考慮
してません。

Yahoo は Html ソースに文法的な誤りが多いので、どのような手法
でも100％確実な結果を得るのは難しいかもしれませんね。

回答No.4

Wendy02

.
しょうがないですね。他の解答が出てしまっては、書かざるを得ないです。
#1のコードでは、description は、こう取ります。

Dim sCont As Strimg
'-------------------------------------------
'Cells(i + 1, 3).Value = arBuf1(0) の次の行の辺りに

k = InStr(1, v, "<DIV class=abs", 1)
m = InStr(k, v, "</DIV", 1)
sCont = Mid(v, k + 15, m - k - 15)
sCont = Replace(sCont, "<B>", "") '強調コード削除
sCont = Replace(sCont, "</B>", "") '強調コード削除
Cells(i + 1, 6).Value = sCont
'セルの書式の配置--全体を折り返し表示するをオフにします。

回答No.3

KenKen_SP

ふと思い出した書き忘れ(´Ａ ｀；)

もし #2 のソースをお試しになる場合は、VBE で
Microsoft HTML Object Library を参照設定して
下さい。

では。

回答No.1

Wendy02

こんばんは。

>特定のキーワードでyahoo検索を実行し
>検索結果から、TITLE・description・URLを抜き取りたいのですが

あくまでも、サンプルですから、description は、取りません。IEが重いようでしたら、Sleep で調整してください。ここまで取れれば、十分だと思います。後は、ログを取って、ご自分で開発してください。
丸投げ質問は禁止ではなくなりましたが、コードを書いてください、とだけではなく、ご自分で考えて、その過程を示してから質問するようにしてください。

'-------------------------------------------
'Option Explicit
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Sub SampleTest1()
　　Dim objIE As Object
　　Dim srchTxt As String
　　Dim HttpLog As String
　　'検索語
　　srchTxt = "VBA"

　　Set objIE = CreateObject("InternetExplorer.Application")
　　With objIE
　　　　'Yahooアクセス
　　　　.Navigate "http://www.yahoo.co.jp/"
　　　　.Visible = True
　　　　Do While .Busy = True
　　　　　　DoEvents
　　　　Loop
　　　　Do Until .ReadyState = 4
　　　　　　DoEvents
　　　　Loop
　　　　'検索ボックスへ入力
　　　　.Document.getElementById("srchtxt").Value = srchTxt
　　　　Sleep 1000 '待ち 1秒
　　　　'検索ボタンクリック
　　　　.Document.forms(0).submit
　　　　Sleep 5000 '待ち 5秒
　　　　HttpLog = .Document.body.innerHTML
　　　　.Quit
　　End With

　　Set objIE = Nothing
　　Call LogCutter(HttpLog)
End Sub
Sub LogCutter(ByVal HttpLog As String)
　　Dim buf As String
　　Dim arBuf As Variant
　　Dim v As Variant
　　Dim i As Long
　　Dim j As Long, k As Long, m As Long
　　Dim sepBuf As String
　　Dim arBuf1 As Variant

　　'セル幅を広げる
　　Columns("A").EntireColumn.ColumnWidth = 40

　　On Error GoTo Errhandler
　　j = InStr(1, HttpLog, "<DIV class=web>", vbTextCompare)
　　If j = 0 Then
　　　　MsgBox "ログが取れません。", vbExclamation
　　　　Exit Sub
　　End If

　　buf = Mid(HttpLog, j)
　　arBuf = Split(buf, "<DIV class=web>") '切り分け

　　For i = LBound(arBuf) To UBound(arBuf)
　　　　v = arBuf(i) '前方
　　　　k = InStr(1, v, "http%3A", vbTextCompare) '後方
　　　　If k > 0 Then
　　　　　　m = InStr(k, v, "</A", vbTextCompare)
　　　　　　sepBuf = Mid$(v, k, m - k)
　　　　　　sepBuf = Replace(sepBuf, "%3A", "")
　　　　　　sepBuf = Replace(sepBuf, "<B>", "") '強調コード削除
　　　　　　sepBuf = Replace(sepBuf, "</B>", "")　'強調コード削除
　　　　　　arBuf1 = Split(sepBuf, """>")
　　　　　　Cells(i + 1, 1).Value = arBuf1(1)
　　　　　　Cells(i + 1, 3).Value = arBuf1(0)
　　　　End If
　　　　v = "": sepBuf = ""
　　Next i
Errhandler:
　　If Err.Number > 0 Then
　　　　MsgBox Err.Number & " : " & Err.Description
　　End If
End Sub