マクロを使ったWEBクエリでデータが正常にできない

マクロを使ったWEBクエリでデータが正常に取得できない


エクセル２０１３を使用しております。
下記ＵＲＬを参考に、マクロでＷＥＢクエリで１１６ページ分の
データ取得用マクロを作成してみたのですが、データ取得が出来ません。

マクロを使用したＷＥＢクエリをご存知の方がいらっしゃいましたら
解決方法をアドバイス頂きたいと思います。


-参考元-
http://oshiete.goo.ne.jp/qa/8208492.html

取得したいＷＥＢページ
http://www.walkerplus.com/spot_list/ar0300/2.html
http://www.walkerplus.com/spot_list/ar0300/3.html
...
http://www.walkerplus.com/spot_list/ar0300/117.h …

取得用シートに記載したＵＲＬ
2.html
3.html
...
117.html


-作成したマクロです-



Sub WEBクエリ実行()

Dim St As Object
Dim I As Integer

Set St = ActiveSheet

Sheets.Add After:=Sheets(Sheets.Count)
For I = 1 To 116
With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.walkerplus.com/spot_list/ar0300/" & Format(St.Cells(I, 1), "@"), Destination:=Range("C" & (I - 1) * 1000 + 1))
.FieldNames = True
.FillAdjacentFormulas = False
.PreserveFormatting = True
.BackgroundQuery = True
.SaveData = True
.AdjustColumnWidth = True
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
Next I
End Sub

-マクロは ここまで-

修正箇所のアドバイス もしくは、
他の方法でも、１１７ページ全て取得可能なマクロをアドバイス頂けると嬉しいです！

No.5 回答者： WindFaller 回答日時： 2014/12/09 16:07

本日(12/9)、バグを見つけました。

PickUpData()の中で、j= j +1 の位置が違っていました。
修正をお願いします。（なお、私の体調へのお気遣いありがとうございます。まだ、バグらしきものは残っているとは思います。)

連続して取るように、Main() プログラムを付け、Sub LogGetting(URL As String)に切り替えました。
全ページは、こちらでは取得していません。

Main()プロシージャの中の
　For i = 2 To Tpage '*ここで最終ページが決まります。
としていますが、試しに、Tpageを10ページ程度試してみることをお勧めします。
　For i = 2 To 10　'これで、10ページです。

'------ 修正後
Sub PickUpData(eaLog As Variant)
-----中略--
　　　'**抽出**
　　　Set Matches = .Execute(eaLog(1))
　　　If Matches.Count > 0 Then
　　　　buf = Matches(0).Submatches(0)
　　　　If InStr(1, buf, "/spot", vbTextCompare) > 0 Then
　　　　　myData(j) = Mid(buf, 1, InStr(2, buf, ">") - 1)
　　　　　j = j + 1
　　　　　myData(j) = Mid(buf, InStr(2, buf, ">") + 1)
　　　　Else
　　　　　myData(j) = buf
　　　　End If
＊＊＊　 j = j + 1はここにあったが、If の外でした。
　　　End If
　　　j = j + 1 '修正
　　Next i

'----------------
'連続に取る場合
Private Const baseURL As String = "http://www.walkerplus.com/"
Dim rw As Long '行数カウンター
Sub Main()
　'ウォーカープラス用のリスト作成ツール
　'http://www.walkerplus.com/spot_list/ar0300/
　Dim i As Long
　Dim eURL As String
　Dim c As Variant
　Dim arTitle As Variant
　Dim Total As Long
　Dim Tpage As Long
　
　'現行のバージョンでは、最終値の自動決定は手動で取れません。
　'そこで、一旦、サイトから、絞り込み検索結果後の全総数を入れてください。
　'例 絞り込み条件：関東　全2915件中26-50件
　
　Total = 2915 'サイトでみた数
　Tpage = Int(Total / 25 + 0.5)
　
　If Total > 10000 Then
　　If MsgBox("1万件を越えます。本当に続行しますか？", vbInformation + vbOKCancel) = vbCancel Then
　　　 Exit Sub
　　End If
　End If
　
　Const TITLES As String = "ジャンル,住所,名称,ランキング,施設紹介,施設紹介画像リンク,詳細データ"
　arTitle = Split(TITLES, ",")
'--------Start---------
　rw = 0 '行の初期化
　ActiveSheet.Cells.Clear
　For i = 1 To 7
　　Cells(1, i).Value = arTitle(i - 1) '今回は数字だけ
　　Cells(1, i).HorizontalAlignment = xlCenter
　Next i
　
　On Error GoTo Errhandler
　For i = 2 To Tpage '*ここで最終ページが決まります。
　　If i = 1 Then
　　　eURL = baseURL & "spot_list/ar0300/"
　　Else
　　　eURL = baseURL & "spot_list/ar0300/" & CStr(i) & ".html"
　　End If
　　Call LogGetting(eURL)
　Next i
　
　'URLをハイパーリンクに変える
　Application.ScreenUpdating = False
　For Each c In Range("F2", Cells(Rows.Count, 6).End(xlUp))
　　If InStr(1, c.Value, "http://", vbTextCompare) > 0 Then
　　　c.Hyperlinks.Add c, c.Value, , , "イメージ"
　　End If
　Next c
　
　For Each c In Range("G2", Cells(Rows.Count, 7).End(xlUp))
　　If InStr(1, c.Value, "http://", vbTextCompare) > 0 Then
　　　c.Hyperlinks.Add c, c.Value & "data.html", , , "詳細データ"
　　End If
　Next c
　Application.ScreenUpdating = True
　
　
　'行幅の調整
　For i = 1 To 7
　　Columns(i).EntireColumn.AutoFit
　Next i
　Exit Sub
Errhandler:
　MsgBox Err.Number & ": " & Err.Description, vbCritical
End Sub

Sub LogGetting(URL As String)
　Dim objHTTP As Object ' New WinHttp.WinHttpRequest
　Dim httpLog As Variant
　Dim strUrl As String
　Dim buf As String
　Dim b() As Byte
　Dim i As Long
　' strUrl = baseURL & "/spot_list/ar0300/2.html"
　If InStr(1, URL, "http://", vbTextCompare) = 0 Then
　　MsgBox "URLが正しくありません。", vbCritical
　　End
　Else
　 '特殊な用途
　End If
　strUrl = Trim(URL)
　Set objHTTP = Nothing
　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　With objHTTP
　　.Open "GET", strUrl, False
　　.Send
　　If .Status <> 200 Then
　　　MsgBox "Err " & .Status
　　　Exit Sub
　　Else
　　　httpLog = .ResponseBody
　　　ReDim b(UBound(httpLog))
　　　For i = LBound(httpLog) To UBound(httpLog)
　　　　b(i) = httpLog(i)
　　　Next
　　　buf = UTF8decode(b)
　　　If IsError(buf) = False Then
　　　　'ログ取得確認
　　　　Call DevideLines(buf)
　　　End If
　　End If
　End With
　Set objHTTP = Nothing
End Sub

No.4 回答者： WindFaller 回答日時： 2014/12/08 20:29

#3の回答者です。

最初に、Webクエリでは、データとしてはきちんと取れませんね。
また、仮に取れても、おそらく、元のコードでは数回もせずにストップしてしまうはずです。
一旦、マクロ文の最後にWebクエリのテーブルを、シートから切り離さないといけなかったはずです。

今回対象のHTMLのログを拾ってみましたが、Internet オートメーションではぬるいので、WinINETで、バイナリで取り、それでログを変換させてみました。サイトの改編になどで取れなくなった時は、PickUpData()の中の「正規表現」をいじれば、すぐに直ります。

>これを１１７ページ分を一気に取得するWEBクエリーのマクロをご教授頂けませんでしょうか？
私は、そこまでは出来ません。それでは、丸投げですから。(というよりも、本日、私は腹痛のため、集中力の限界)　そもそも、私は気まぐれで書いたものですから、フィードバックはあまりしたくありません。また、補足につけられても、次回に、ここに戻るまでは日にちが立ってしまいますので、気に入らなければ、見捨てて結構です。

一応、ヒントとしては、以下のプロシージャの前に、Main()プロシージャを造り、URLをループして、ページを進ませれば済みます。

http://www.walkerplus.com/spot_list/ar0300/　　　'1ページ目
http://www.walkerplus.com/spot_list/ar0300/2.html　'2ページ目
http://www.walkerplus.com/spot_list/ar0300/3.html　'3ページ目

この程度は、ループで簡単に生成できるはずです。
なお、本来は、配列変数に全部入れれば、速いし見栄えもよいのですが、最後のほうは、こちらの体力の限界値のための手抜きです。

これを、
LogGettingの引数に、その都度、strURLを変化させて、Main()から、送り込めばよいわけです。

Sub LogGetting(strURL As String)

End Sub

それでは、しばらくお休みいたします。

この回答へのお礼

体調が悪い中、対応頂きありがとうございました！

アドバイス頂いた内容を元にチャレンジしてみたいと思います。

お礼日時：2014/12/08 21:13

No.3 回答者： WindFaller 回答日時： 2014/12/08 20:19

コードは以下の通りです。

#1の補足で、最後に詳細データのURLがないとまずいと思いましたので、加えました。
1ページ目を取った後でも、レイアウトは手動でしてください。その後は、マクロを改編して、一気に行ってもよいと思います。解説はのちほど。

'//
Option Explicit

Private Const baseURL As String = "http://www.walkerplus.com/"　'ベースURL
Dim rw As Long '行数カウンター
Sub LogGetting()
　Dim objHTTP As Object ' New WinHttp.WinHttpRequest
　Dim httpLog As Variant
　Dim strUrl As String
　Dim buf As String
　Dim b() As Byte
　Dim i As Long
　rw = 0 '行の初期化
　For i = 1 To 7
　 Cells(1, i).Value = i '今回は数字だけ
　 Cells(1, i).HorizontalAlignment = xlCenter
　Next i
　strUrl = baseURL & "/spot_list/ar0300/2.html" '本来は、ここが変わっていく
　Set objHTTP = Nothing
　Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
　With objHTTP
　　.Open "GET", strUrl, False
　　.Send
　　If .Status <> 200 Then
　　　MsgBox "Err " & .Status
　　Else
　　　httpLog = .ResponseBody
　　　ReDim b(UBound(httpLog))
　　　For i = LBound(httpLog) To UBound(httpLog)
　　　　b(i) = httpLog(i)
　　　Next
　　　buf = UTF8decode(b)
　　　If IsError(buf) = False Then
　　　　Call DevideLines(buf)
　　　End If
　　End If
　End With
　Set objHTTP = Nothing
End Sub

Public Function UTF8decode(ByRef b() As Byte) As String
' UTF-8から変換:引数; b()- Byte Array
　Dim objStrm As ADODB.Stream
　On Error GoTo ErrHandler
　Set objStrm = CreateObject("ADODB.Stream")
　 'Set objStrm = New ADODB.Stream
　With objStrm
　　 .Open
　　 .Type = adTypeBinary
　　 .Write b
　　 .Position = 0
　　 .Type = 2　'TypeText
　　 .Charset = "UTF-8"
　UTF8decode = objStrm.ReadText()
　　 .Close
　End With
　Set objStrm = Nothing
　Exit Function
ErrHandler:
　UTF8decode = CVErr(xlErrValue)
　If objStrm Is Nothing = False Then objStrm.Close
　Set objStrm = Nothing
End Function

Sub DevideLines(buf As String)
Dim Log As String
Dim i As Long, j As Long
Dim arLog1 As Variant
Dim arLog2 As Variant
　i = InStr(1, buf, "<!-- spot -->", vbTextCompare)
　Log = Mid(buf, i)
　arLog1 = Split(Log, "<div class=""ph-m border"">", , vbBinaryCompare)
　For j = 1 To UBound(arLog1)
　　 arLog2 = Split(arLog1(j), "<div class=""bar"">", , vbBinaryCompare)
　　 Call PickUpData(arLog2)
　Next j
End Sub
'---------------------------------------
Sub PickUpData(eaLog As Variant)
　Dim arPats As Variant
　Dim Pat As String
　Dim i As Long, j As Long
　Dim x As Long, y As Long, z As Long
　Dim buf As String
　Dim myData(6) As Variant
　Dim Matches As Object
　With CreateObject("VBScript.RegExp")
　　'1 ジャンル, 2 住所, 3 名称, 4 ランキング, 5 施設紹介, 6 施設画像URL
　　'正規表現パターン
　　arPats = Array("<p>([^<]+)<span class=""red"">", _
　　"/span>([^<]+)</p>", _
　　"2><a href=""[^>]+>([^<]+)</a", _
　　">＜([^＞]+)＞</a", _
　　"class=""txt"">([^<]+)</p")
　　For i = 0 To UBound(arPats)
　　　Pat = arPats(i)
　　　.Pattern = Pat
　　　.Global = False
　　　'**抽出**
　　　Set Matches = .Execute(eaLog(1))
　　　If Matches.Count > 0 Then
　　　　buf = Matches(0).Submatches(0)
　　　　If InStr(1, buf, "/spot", vbTextCompare) > 0 Then
　　　　　myData(j) = Mid(buf, 1, InStr(2, buf, ">") - 1)
　　　　　j = j + 1
　　　　　myData(j) = Mid(buf, InStr(2, buf, ">") + 1)
　　　　Else
　　　　　myData(j) = buf
　　　　End If
　　　　j = j + 1
　　　End If
　　Next i
　　On Error Resume Next
　　x = InStr(1, eaLog(0), "<img src=", vbBinaryCompare) + Len("<img src=") + 1
　　y = InStr(1, eaLog(0), "jpg"" alt=") + 3 '拡張子分
　　If InStr(1, eaLog(0), "noimage", vbBinaryCompare) = 0 Then
　　　myData(5) = Mid(eaLog(0), x, y - x) 'イメージデータ
　　Else
　　　myData(5) = "NoImage"
　　End If
　　z = InStr(1, eaLog(0), "<a href=", vbTextCompare) + Len("<a href=""")
　　myData(6) = baseURL & Mid(eaLog(0), z, x - z - Len("<img src=") - 3) '詳細URL
　　Call OutPutSheet(myData())
　　Erase myData()
　　On Error GoTo 0
　End With
End Sub
Sub OutPutSheet(myData() As Variant)
　Dim j As Long
　Dim dummy As Variant
　On Error Resume Next
　dummy = UBound(myData)
　If rw = 0 Then
　　 rw = 2 '初期行数
　End If
　If Err.Number > 0 Then
　　dummy = ""
　　Exit Sub
　End If
　On Error Resume Next
　For j = 0 To UBound(myData)
　 Cells(rw, j + 1).Value = myData(j)
　Next j
　On Error GoTo 0
　rw = rw + 1
End Sub

'//

No.2 回答者： weboner 回答日時： 2014/12/08 15:44

まずは、

WEBクエリでの外部データの取り込みで
http://www.walkerplus.com/spot_list/ar0300/2.html
を読み込んでみてください

↑
コレ自体をマクロの記録でマクロ化すると

Sub Macro1()
'
' Macro1 Macro
'

'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.walkerplus.com/spot_list/ar0300/2.htm … Destination:=Range( _
"$A$1"))
.Name = "2"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub

こうなります

ページ自体がテーブル化されていないので、ページ全体を読み込む必要があります

個々の施設の情報は

---------ここから

かみねレジャーランド　-------施設画像のalt属性（WEBクエリでは画像のURLは取得できません）

遊園地●茨城県日立市　-------ジャンルと住所
かみねレジャーランド　-------施設名

＜茨城県・アクセスランキング第4位＞

太平洋を一望できる本格レジャー施設　-------施設紹介

イベントなし
駐車場あり
送迎なし

地図｜ 詳細データ｜ おすすめポイント｜

---------ここまで

WEBクエリで取得した情報から必要な部分のみを抜き出すマクロを別に用意する必要があります

提示されたサイト自体WEBクエリで処理するには適していないようにも思われます

この回答への補足

追加の情報ありがとうございます。

単体ページの取得イメージは出来ました。
これを１１７ページ分を一気に取得する
WEBクエリーのマクロをご教授頂けませんでしょうか？

必要データの抜出は、エクセルで手動で行います。

補足日時：2014/12/08 16:17

No.1 回答者： weboner 回答日時： 2014/12/08 10:40

そもそも

http://www.walkerplus.com/spot_list/ar0300/2.html
↑
このサイトのなんの情報を取得したいのか？

サイト自体にはテーブルで指定できる情報は広告以外は有りません

.WebTables = "1"
↑
テーブル番号1番のデータはサイト内の
KADOKAWA 注目情報
にあるバナースペースです

マクロにする前に一度外部データの取り込みからWEBクエリを実行してみましたか？

この回答への補足

※質問の補足です

取得したいデータは以下のデータです。

１　ジャンル
２　住所
３　名称
４　ランキング
５　施設紹介
６　施設画像URL


例）
遊園地,●茨城県日立市,かみねレジャーランド,＜茨城県・アクセスランキング第4位＞,太平洋を一望できる本格レジャー施設,http://ms-cache.walkerplus.com/walkertouch/wtd/i …（画像のURL）

動物園,●茨城県日立市,日立市かみね動物園,,太平洋を眺めながら動物と触れ合える,http://ms-cache.walkerplus.com/walkertouch/wtd/i …

といった形で取得できると嬉しいです。

アドバイスよろしくお願いします。

補足日時：2014/12/08 11:28