ＶＢＡマクロコード

エクセルで複数URLのリンク先から、「在庫状況」「旧定価がいくらか」「ＩＳＢＮバーコードの番号」という３つの情報を引っ張ってくることはできないでしょうか？
Aの列にあらかじめURLを100個ほど入力し、マクロでもいいですが、リンク先の情報を取得して、B,C,Dの列に引っ張ってくるシステムが欲しいです。

具体的には、このような表を作りたいです。

__A____ ____B＿＿ ____C＿＿ ＿____D＿＿＿＿
ＵＲＬ１ 在庫取り寄せ 1500 9784331059685
ＵＲＬ２ 品切れ 2500 9784860951344
ＵＲＬ３ 現在お取扱いできません 2400 ] 9784899771579
・ ・ ・
・ ・ ・
・ ・ ・
在庫情報はソースでは、
<p class="status_1">在庫取寄せ<br/>
通常1週間以内発送</p><!-- 青 -->


<p class="status_2">品切れ<br/>
ご注文は可能 入荷しない場合あり</p><!-- 赤 -->

<p class="status_3">現在お取扱いできません</p><!-- 灰 -->
の３種類です。ＵＲＬ１でいうと、
旧定価は<p class = "geb_itemDetailTtlKbValue1"><span>旧定価：１，５００円＋税／ＢＳ分類：民俗・風俗・文化・地誌・紀行・他<br />で、
ＩＳＢＮバーコードの番号は<br />BS(9784331059685/0-04427)</span></p>で囲まれています。

ＵＲＬ１ http://www.bookservice.jp/bs/ItemDetail?cmId=634 …
ＵＲＬ２ http://www.bookservice.jp/bs/ItemDetail?cmId=629 …
ＵＲＬ３ http://www.bookservice.jp/bs/ItemDetail?cmId=615 …

在庫状況は本タイトルの下、旧定価とＩＳＢＮバーコードは内容紹介の上下にあります。
よろしくお願い致します。

質問者からの補足コメント

• WinHttp.WinHttpRequestが参照可能なライブラリファイルに無いのですが、どこでダウンロードすればいいのでしょうか？探したが見つからなかったので、レイト・バインディングを一応教えてもらえますか？
  
  また、「エラーが頻繁に出るようでしたら、ここ以下を外す」というのは、
  　If oWinHttp Is Nothing Then～MsgBox "アクセスに失敗しました。"
  までを外すという意味でしょうか？

    補足日時：2015/06/14 17:32

• おかげさまで正常に起動しました。丁寧に画像付きで説明してくださり、ありがとうございました。ところで、相手側のサーバーに負担をかけないようにスリープを１秒入れるなどした方が良いのでしょうか？お察しのとおり、初心者なもので良くわからないのですが、１つのＵＲＬを調べるごとに１秒スリープを入れた方が良いですか？また、その場合コード中のどこにＳleep(1)を入れたらよいでしょうか？宜しくお願いします。

    補足日時：2015/06/14 20:33

No.3 回答者： WindFaller 回答日時： 2015/06/15 09:16

>相手側のサーバーに負担をかけないようにスリープを１秒入れるなどした方が良いのでしょうか？

それは、難しい相談ですね。今のところは加えなくてもよいと思います。

ダメな時は、Sleepとか関係がなく別途ボタン操作などを加えて、直接閲覧できないようにされてしまいます。このマクロを考える時点で、サイトで禁止されていないことは、こちらで確認しました。最近、有名サイトは、今回のようなWebスクレイピングが禁止している所がありますが、そこは、アクセス数が半端ないということもあります。今回のような内容は、確かにサーバーには負担を掛けていると思います。

※何らかの処置された時には、その対応として、WinHttp を使わずに、InternextExplorer に換えればよいと考えています。ただ、手よりは速くても、かなり遅い反応になってしまいます。たぶん、コードは、今以上にややこしいと想像しています。

スリープは、モジュール画面の一番上（Option Explicitがあれば、その下に入れます）

そして、単位は、
Sleep 1000　 '1/1000 秒×1,000 =(1000ms=1秒）

また、画像を参考にしてください。

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

Sleep の掛ける場所ですが、ループの
Sub Main()
'－中略－
For Each c In Range("A2", Cells(Rows.Count, 1).End(xlUp))
　 rw = c.Row
　If c.Value Like "http://www.bookservice.jp/bs/ItemDetail?cmId=" Then
　　 Call GetHttpLog(c.Value)
　　　Sleep 1000　　　'ここがよいだろうと思います。
　ElseIf c.Value Like "#######" Then
　　　sURL = adrBASE & c.Value
　　 Call GetHttpLog(sURL)
　End If
Next

No.2 回答者： WindFaller 回答日時： 2015/06/14 18:36

>WinHttp.WinHttpRequestが参照可能なライブラリファイル

これは、WinHttp　だけでした。失礼しました。

とりあえず、図を貼り付けますので、それで、探して設定してください。

内容的に、数回程度ならともかく、短い時間に同じサイトに100回もアクセスをする場合には、レイト・バインディングの方法は、お勧めしません。

その書き方は、一応、
Set oWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
となります。ただし、今回、この方法で書き換える、というようなリクエストは、なにとぞご容赦願います。

>「エラーが頻繁に出るようでしたら、ここ以下を外す」というのは、
この文言で、質問されるということは、ほとんど、VBAはお分かりになりませんか？これは、先頭のコメント・ブロック('')が入っている部分を外すということです。

''が先頭にない
On Error GoTo ErrHandler　　'エラーが頻繁に出るようでしたら、ここ以下を外す
　　－中略－（そのまま）
ErrHandler:　'上記のErrHandler を外したら、こちらも、End Ifまで外す
If Err() > 0 Then
　 MsgBox Err.Number & " " & Err.Description
End If

No.1 回答者： WindFaller 回答日時： 2015/06/14 10:09

最初に、

http://www.bookservice.jp/
ここを起点ということで解釈しました。
「在庫状況」「旧定価がいくらか」「ＩＳＢＮバーコードの番号」
これには、書名は不要のようです。
また、サイトの利用規約では、以下のようなスクレイピングの行為は禁止されていないようですが、あまり多用することは、トラブルの元になりますので、十分に余裕を以ってご利用するようにお願いします。

URLを置くのもよいのですが、Id番号の7桁の数字だけでも良いようにしました。

注意：以下のコードでは、レイト・バインディングでもよいのですが、あえて、事前バインディングにしましたので、必ず参照設定をしてください。基本的にエラー処理はしていますが、そうでない場合は、エラートラップ(ErrHandler)を外してください。

また、データは、A2の2行目からを最初としています。

'//標準モジュール
'Option Explicit
Private oWinHttp As WinHttp.WinHttpRequest　'参照設定　WinHttp.WinHttpRequest.#.#
Private oHtml As HTMLDocument '参照設定　Microsoft HTML Object Library
Private rw As Long
Sub Main()
Dim c As Range
Dim sURL As String
Const adrBASE As String = "http://www.bookservice.jp/bs/ItemDetail?cmId="
For Each c In Range("A2", Cells(Rows.Count, 1).End(xlUp))
　 rw = c.Row
　If c.Value Like "http://www.bookservice.jp/*" Then
　　 Call GetHttpLog(c.Value)
　ElseIf c.Value Like "#######" Then
　　　sURL = adrBASE & c.Value
　　 Call GetHttpLog(sURL)
　End If
Next
Set oWinHttp = Nothing
End Sub
Sub GetHttpLog(ByVal strURL As String)
　　Dim HttpLog As String
　　Dim Ar As Variant
　　Dim n As Variant
　　''On Error GoTo ErrHandler　　'エラーが頻繁に出るようでしたら、ここ以下を外す
　　If oWinHttp Is Nothing Then
　　Set oWinHttp = New WinHttp.WinHttpRequest '("WinHttp.WinHttpRequest.5.1")
　　End If
　　oWinHttp.Open "GET", strURL, False
　　oWinHttp.Send
　　If oWinHttp.Status = 200 Then
　　　　HttpLog = oWinHttp.ResponseText
　　　　Call GetStatus(HttpLog)
　　Else
　　　　MsgBox "アクセスに失敗しました。"
　　End If
Exit Sub
''ErrHandler:　'上記のErrHandler を外したら、こちらも、End Ifまで外す
''If Err() > 0 Then
''　 MsgBox Err.Number & " " & Err.Description
''End If
End Sub
Sub GetStatus(HttpLog As String)
　Dim iP, iDtl, exPrc, mb
　Dim Stk As String, ISBN As String
　Set oHtml = New HTMLDocument
　oHtml.body.innerHTML = HttpLog
　With oHtml
　　Set mb = .getElementsByClassName("mb10 clearfix")
　　If mb.Length > 0 Then
　　　Stk = Split(mb(0).innerText, vbCrLf)(0)
　　End If
　　Set iP = .getElementsByClassName("geb_itemPropValue2") 'ISBNコード
　　If iP.Length > 0 Then
　　　ISBN = Split(iP(0).innerText, vbCrLf)(0)
　　End If
　　Set iDtl = .getElementsByClassName("geb_itemDetailTtlKbValue1") '旧定価
　　If iDtl.Length > 0 Then
　　　If InStr(iDtl(0).innerText, "旧定価") > 0 Then
　　　　exPrc = Split(iDtl(0).innerText, "／")(0)
　　　　exPrc = Replace(exPrc, "旧定価：", "", , , 1)
　　　　exPrc = Replace(exPrc, "＋税", "", , , 1)
　　　End If
　　End If
　End With
　'出力
　With ThisWorkbook.ActiveSheet
　　Application.ScreenUpdating = False
　　Cells(rw, 2).Value = Stk
　　Cells(rw, 3).Value = StrConv(exPrc, vbNarrow)
　　Cells(rw, 4).Value = "'" & Trim(ISBN)
　　Application.ScreenUpdating = True
　End With
End Sub
'///