VBAでURLからソース内の指定文字列を取り出す

質問

今、VBAを勉強中です！

例えばA列に1000件のヤフーオークション出品物のURLがあります。
そのURLからソースを読み込み、B列に“現在価格”のみを表示させる場合はどのようにすれば良いでしょうか？

ヤフーオークションのソースを見ると下記のようになっています。

---------------------------------------
<tr>
<th>現在の価格<br><img src="http://i.yimg.jp/images/space.gif" width="150" height="1" alt=""></th>
<td class="decClnTxt">：&nbsp;</td>
<td ><p property="auction:Price">●●●●円</p>
---------------------------------------

“●●●●円”の部分を“B列”に表記させれるようにしたいです。

お詳しい方、ご教授頂ければ大変助かります。何卒よろしくお願い致しますm(__)m

回答No.3

DOUGLAS_

＃結果によって、表示を変えてみました。

Option Explicit
Sub Macro1()
　　Dim objHTTP As Object
　　Dim i As Long
　　Dim myURL As String
　　Dim strHtml As String
　　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　　Columns("B").Clear
　　Application.ScreenUpdating = False
　　For i = 1 To Range("A1").End(xlDown).Row
　　　　myURL = Range("A" & i).Value
　　　　With objHTTP
　　　　　　.Open "GET", myURL, False
　　　　　　.Send
　　　　　　If .Status = 200 Then strHtml = .responseText
　　　　End With
　　　　If InStr(strHtml, "指定されたドキュメントは存在しません") > 0 Or _
　　　　　 InStr(strHtml, "指定したオークションIDは無効です") > 0 Then
　　　　　　Range("B" & i).Value = "URL エラー"
　　　　Else
　　　　　　If InStr(strHtml, "このオークションは終了しています") > 0 Then
　　　　　　　　If InStr(strHtml, "auction:Price") > 0 Then
　　　　　　　　　　Range("B" & i).Value = _
　　　　　　　　　　　　Format(Split(Left(Split(strHtml, "auction:Price"">")(1), 10))(0), "#,##0 終")
　　　　　　　　Else
　　　　　　　　　　Range("B" & i).Value = _
　　　　　　　　　　　　Format(Split(Left(Split(strHtml, "auction:BidOrBuyPrice"">")(1), 10))(0), "#,##0 終")
　　　　　　　　End If
　　　　　　Else
　　　　　　　　If InStr(strHtml, "<th>即決価格<br>") > 0 Then
　　　　　　　　　　Range("B" & i).Value = Format(Split(Left(Split(strHtml, "auction:BidOrBuyPrice"">")(1), 10))(0), "#,##0 即")
　　　　　　　　Else
　　　　　　　　　　If InStr(strHtml, "auction:Price") > 0 Then
　　　　　　　　　　　　Range("B" & i).Value = _
　　　　　　　　　　　　　　Format(Split(Left(Split(strHtml, "auction:Price"">")(1), 10))(0), "#,##0 円")
　　　　　　　　　　Else
　　　　　　　　　　　　If InStr(strHtml, "アダルト") > 0 Then
　　　　　　　　　　　　　　Range("B" & i).Value = "アダルト"
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　Range("B" & i).Value = "要ログイン"
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
　　With Columns("B:B")
　　　　.HorizontalAlignment = xlRight
　　　　.Columns.AutoFit
　　End With
　　Application.ScreenUpdating = True
　　Set objHTTP = Nothing
End Sub

回答No.2

kumatti1

上部の「商品の情報」ではなくて、下部の「入札、ウォッチリスト登録」なら一発で済みますね。
MsgBox ie.document.getElementsByClassName("decClnTxt02")(0).innerText

回答No.1

cj_mover

こんにちは。

私としてはあまり得意な分野ではありませんので詳しくはありませんが（レスがないようなので）、
概要としてはこんな感じで行けるんじゃないでしょうか。

正しいURLがあるセルを指定出来ていない場合は
エラー制御が必要ですが、省略します。
　Range("A2").CurrentRegion.Columns(1).Cells
A列の範囲指定法など、工夫してみてください。

Sub Re8100997()
　　Dim oIE As Object
　　Dim oRegExp As Object
　　Dim oM As Object
　　Dim r As Range
　　Dim sBuf As String

　　Set oIE = CreateObject("InternetExplorer.Application")
　　oIE.Visible = True

　　Set oRegExp = CreateObject("VBScript.RegExp")
　　oRegExp.Global = True
　　oRegExp.Pattern = "<p property=""auction:Price"">([^<]*)<"

　　With oIE
　　　　For Each r In Range("A2").CurrentRegion.Columns(1).Cells
　　　　　　.Navigate2 r.Value
　　　　　　While .Busy Or .ReadyState < 4
　　　　　　　　DoEvents
　　　　　　Wend
　　　　　　sBuf = .Document.Body.innerHTML
　　　　　　Set oM = oRegExp.Execute(sBuf)
　　　　　　r.Offset(, 1).Value = oM(0).SubMatches(0)
　　　　Next
　　　　.Quit
　　End With

　　Set oIE = Nothing
　　Set oRegExp = Nothing
End Sub