マクロを使ったWEBクエリでデータが正常に取得できない
エクセル2013を使用しております。
下記URLを参考に、マクロでWEBクエリで116ページ分の
データ取得用マクロを作成してみたのですが、データ取得が出来ません。
マクロを使用したWEBクエリをご存知の方がいらっしゃいましたら
解決方法をアドバイス頂きたいと思います。
-参考元-
http://oshiete.goo.ne.jp/qa/8208492.html
取得したいWEBページ
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 …
取得用シートに記載したURL
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
-マクロは ここまで-
修正箇所のアドバイス もしくは、
他の方法でも、117ページ全て取得可能なマクロをアドバイス頂けると嬉しいです!
A 回答 (5件)
- 最新から表示
- 回答順に表示
No.5
- 回答日時:
本日(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
- 回答日時:
#3の回答者です。
最初に、Webクエリでは、データとしてはきちんと取れませんね。
また、仮に取れても、おそらく、元のコードでは数回もせずにストップしてしまうはずです。
一旦、マクロ文の最後にWebクエリのテーブルを、シートから切り離さないといけなかったはずです。
今回対象のHTMLのログを拾ってみましたが、Internet オートメーションではぬるいので、WinINETで、バイナリで取り、それでログを変換させてみました。サイトの改編になどで取れなくなった時は、PickUpData()の中の「正規表現」をいじれば、すぐに直ります。
>これを117ページ分を一気に取得する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
それでは、しばらくお休みいたします。
No.3
- 回答日時:
コードは以下の通りです。
#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
- 回答日時:
まずは、
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クエリで処理するには適していないようにも思われます
この回答への補足
追加の情報ありがとうございます。
単体ページの取得イメージは出来ました。
これを117ページ分を一気に取得する
WEBクエリーのマクロをご教授頂けませんでしょうか?
必要データの抜出は、エクセルで手動で行います。
No.1
- 回答日時:
そもそも
http://www.walkerplus.com/spot_list/ar0300/2.html
↑
このサイトのなんの情報を取得したいのか?
サイト自体にはテーブルで指定できる情報は広告以外は有りません
.WebTables = "1"
↑
テーブル番号1番のデータはサイト内の
KADOKAWA 注目情報
にあるバナースペースです
マクロにする前に一度外部データの取り込みからWEBクエリを実行してみましたか?
この回答への補足
※質問の補足です
取得したいデータは以下のデータです。
1 ジャンル
2 住所
3 名称
4 ランキング
5 施設紹介
6 施設画像URL
例)
遊園地,●茨城県日立市,かみねレジャーランド,<茨城県・アクセスランキング第4位>,太平洋を一望できる本格レジャー施設,http://ms-cache.walkerplus.com/walkertouch/wtd/i …(画像のURL)
動物園,●茨城県日立市,日立市かみね動物園,,太平洋を眺めながら動物と触れ合える,http://ms-cache.walkerplus.com/walkertouch/wtd/i …
といった形で取得できると嬉しいです。
アドバイスよろしくお願いします。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/03/08 09:08
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2023/03/07 14:05
- Visual Basic(VBA) Excelのマクロコードについて教えてください 1 2022/03/27 12:02
- Visual Basic(VBA) マクロ実行時、自動で背景色を変えたい。 C列にあるチェックボックスをチェックするとB列に「TRUE」 4 2022/11/08 11:14
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/03/12 10:10
- Visual Basic(VBA) エクセルのマクロについて教えてください。 5 2023/06/02 08:44
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2022/10/13 08:41
- Excel(エクセル) 【マクロ】webアドレスにて指定されたCSVファイル【excelソフト表示】を印刷する件 1 2023/02/15 01:52
- Visual Basic(VBA) EXCEL VBAにて動的にCheckBOXを複数作成し、同BOXにイベントを追加したい 1 2023/03/16 07:05
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/06/04 09:39
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセル初心者です 関数の入れ...
-
【関数】先頭だけにある、半角...
-
エクセル 白黒印刷で白線を印刷...
-
Excelのチェックボックスの使い...
-
【関数】適切な文字数の数字を...
-
Excelのpivotについて質問です
-
Excel ピボットテーブルで日付...
-
LOOKUP関数を使えばいいのでし...
-
エクセル関数を教えてください
-
エクセルのセルに同じ大きさの...
-
UNIQUE関数が使えないバージョ...
-
excelの不要な行の削除ができな...
-
エクセルで「-0.0」と表示さ...
-
時間によってファイル名が変わ...
-
WPS OFFICEでの縦書きについて
-
エクセルの関数について教えて...
-
Aというブックの1というシート...
-
【マクロ】シート名を取得する...
-
VBA Private Sub Worksheet_Cha...
-
VBA、Excelのworkbook.open に...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel 2019 のピボットテーブル...
-
[関数得意な方]教えて下さい・...
-
Excelにてある膨大なデータを管...
-
[関数について]わかる方教えて...
-
Excel初心者です。 詳しい方、...
-
excelの不要な行の削除ができな...
-
エクセル関数に詳しい方教えて...
-
INDIRECTを使わず excelで複数...
-
[オートフィルタ]で抽出された...
-
エクセルの神よ、ご回答を! エ...
-
エクセル関数に詳しい方、教え...
-
各ページの1番上の表示について
-
Excelで写真のような表を作った...
-
エクセルで不等号記号(≠)が上に...
-
数学 Tan(θ)-1/Cos(θ)について...
-
Excel 2019 は、SPILL機能があ...
-
Excelで全角を半角にしたいので...
-
条件付き書式を教えてください
-
Excel フィルターを掛けた状態...
-
[オートフィルタ]の適用範囲の...
おすすめ情報