VBAでＷＥＢもっと見るを押して情報を取得し続けたい。

Question

すみません。誰か助けてください。ＶＢＡ以下ＵＲＬからスクレイピングツールを作成していますが、もっと見るが押せず２０件でマクロが止まってしまいます。もっと見るを押して、次のデータを取得できるＶＢＡコードを教えていただけないでしょうか？ＵＲＬ http://store.disney.co.jp/search/goodssearch.aspx?scene=newitem どなたかご教授お願いいたします。ここら辺があやしいと思われる箇所です。

WindFaller · Accepted Answer

スクレーピング禁止令は、私の見た限りでは出てきませんでしたが、ここのサイトは大丈夫でしょうか。

ディズニー関連は、いろいろ文句が来るような話も聞きます。こうやって取れるのも、ほんの短い期間かもしれません。内容にそれほど責任はもてませんが、常識的な範囲で試してみてください。後で、プロバイダーを通して、ペナルティなど来ないよう祈るばかりです。

わざと、Sleep を入れて止めています。ほんの気休めです。
私のやり方を参考にしてみてください。
2行目から出すようになっています。

'//標準モジュール

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

Sub GetDatathruIE()
　　Dim strURL As String
　　Dim objIE As Object
　　Dim i As Long, j As Long, a As Long
　　Dim k As Long, v As Long, cnt As Long, page As Long
　　Dim lastCell As Range
　　Dim cbtn
　　Dim itm_Ea
　　Dim itm_C
　　Dim itmLists, pn
　　Dim ar
　　Dim buf
　　Dim MaxItm　　As Long
　　
　　strURL = "http://store.disney.co.jp/search/goodssearch.asp …
　　On Error GoTo ErrHandler
　　Set objIE = CreateObject("InternetExplorer.Application")
　　objIE.Navigate2 strURL
　　' objIE.Visible = True　　''最初はVisible はTrueにしたほうがよいです。
　　Do While objIE.Busy Or objIE.ReadyState <> 4: DoEvents: Loop
　　　　With objIE
　　　　　　Set pn = .document.GetElementsbyClassName("p-navbar__result")
　　　　　　If pn.Length = 0 Then
　　　　　　　　MsgBox "サイトが変わったか、全アイテム数が取れません", vbExclamation
　　　　　　　　Exit Sub
　　　　　　Else
　　　　　　　　MaxItm = Val(Replace(pn(0).innerText, "全", "")) 'アイテム全部の数を取る
　　　　　　End If
　　　　　　page = Int(MaxItm / 20) - CInt(((MaxItm Mod 20) > 0)) 'ページ数
　　　　　　''GoTo ErrHandler '(サイトが開くか予行演習）
　　　　　　
　　　　　　'-------------------これ以降がデータ取得------------
　　　　　　For a = 1 To page
　　　　　　　　If a = 1 Then
　　　　　　　　　　Set itmLists = .document.GetElementsbyClassName("item-list grid")
　　　　　　　　Else
　　　　　　　　　　Set itmLists = .document.GetElementsbyClassName("new li_item" & CStr((a - 1) * 20))
　　　　　　　　End If
　　　　　　　　If itmLists.Length = 1 Then
　　　　　　　　　　Set itm_Ea = itmLists(0)
　　　　　　　　　　Set itm_C = itm_Ea.ChildNodes
　　　　　　　　End If
　　　　　　　　If a = 1 Then
　　　　　　　　　　j = 1 '行の始まりの一つ手前(2行目から）
　　　　　　　　Else
　　　　　　　　　　Set itm_C = itmLists
　　　　　　　　End If
　　　　　　　　'--------------
　　　　　　　　For i = 0 To itm_C.Length - 1
　　　　　　　　　　If TypeName(itm_C(i)) = "HTMLLIElement" Then
　　　　　　　　　　　　buf = Trim(itm_C(i).innerText)
　　　　　　　　　　　　v = 1
　　　　　　　　　　　　ar = Split(buf, vbCrLf)
　　　　　　　　　　　　For k = 0 To UBound(ar) - 1
　　　　　　　　　　　　　　If Trim(ar(k)) <> "" Then
　　　　　　　　　　　　　　If Trim(ar(k)) Like "詳細を見る*" Then Exit For
　　　　　　　　　　　　　　　　Cells(j + 1, v).Value = ar(k)
　　　　　　　　　　　　　　　　DoEvents '暴走を止めるため
　　　　　　　　　　　　　　　　If Val(ar(k)) > 0 Then Exit For '.ループから抜け出る
　　　　　　　　　　　　　　　　v = v + 1
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next k
　　　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　　　j = j + 1 'jは行数
　　　　　　　　　　　　If cnt > MaxItm Then Exit For '' jは行数であり、アイテム数, 全アイテム数よりも越えたらおしまい
　　　　　　　　　　End If
　　　　　　　　　　buf = ""
　　　　　　　　　　If IsArray(ar) Then
　　　　　　　　　　　　Erase ar
　　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　　　' GoTo ErrHandler 'ここを外すと、1回で終わる
　　　　　　　　If a = 1 Then
　　　　　　　　　　Set cbtn = .document.GetElementByID("c-btn-more")
　　　　　　　　ElseIf a = page Then
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　　　cbtn.Click
　　　　　　　　Sleep 2000
　　　　　　Next a
　　　　End With
ErrHandler:
　　　　Set lastCell = Cells(Rows.Count, 1).End(xlUp)
　　　　Range("A1", lastCell).Resize(, 4).WrapText = False
　　　　If Err <> 0 Then
　　　　　　 MsgBox Err.Description
　　　　Else
　　　　　　MsgBox MaxItm & "件正常終了しました。", vbInformation
　　　　End If
　　　　objIE.Quit
　　　　Set objIE = Nothing
End Sub
'//取得画面

WindFaller · Answer

#1の回答者です。

> スクレーピングって危険なんですね。。。。

一部では、すごく嫌われているみたいです。代表的なものは、ハローワークの仕事検索とかダメになりましたね。モーグも、アマゾンもダメですね。他にも、証券・為替でサイトによって取れないところや、改行コードが、Windows標準と違うと、取れないところがあります。

でも、今のやり方なら、そんなに何度もするわけではないから、問題はないと思うのですが……。１日に１度、変わる程度だと思います。

VBAでＷＥＢもっと見るを押して情報を取得し続けたい。

スクレーピング禁止令は、私の見た限りでは出てきませんでしたが、ここのサイトは大丈夫でしょうか。

#1の回答者です。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング