VBAで手っ取り早くWebスクレイピング

某企業のインターンシップでプライベートブランドの研究をしたことがあり、前々からWebスクレイピングに興味があったので、例によってExcelのVBAで簡単なコードを書いて、セブンプレミアムの一覧表を作りました。セブンのWebページはURLが定型化（0～9999までのID）されており、普通にFor文をぶん回すという荒業で対応できます。要するにセブンのページに1万回アクセスするのがマクロの趣旨です。IDが不規則な場合には、まず商品一覧からID表をスクレイピングして、それをもとにもう一回内容を取りに行くという二段階になります。

1万回といった大量のアクセスを迷惑行為ととらえるかどうか。例えば2010年の岡崎図書館事件では、サーバーダウンが発生し作成者が逮捕され物議をかもしました（そののち起訴猶予処分）。私の見解としては、1万回程度のアクセスの単発実行であれば、スクリプトの作りにもよるが今どきのサーバーが落ちる可能性は薄いと考えています。クローリングという行為自体はグーグルやアマゾンのような大企業から、有象無象の個々人まで好き勝手にやっている現状であり、インターネットの自由空間では問題が無いと思います。しかしもしサーバーをダウンさせてしまうことになれば、たとえ法的な処罰を受けなくとも、誰かに迷惑をかけることになってしまいます。従って、以下ソースの利用は自己判断・自己責任で行ってください。以下のソースは、セブンに迷惑がかからないように、URLの一部をマスキングしています。

Excel VBAはどの会社でも使えるから最強の実行環境だと思います。でもソースも汚いし、VBAを沢山書いたからといってプログラマとしての成長にはつながりません。私はこれまで、あくまで事務職の立場から、以下にコピペ等で速く情報を処理できるかを考えてVBAを書いてきました。会社ではそういう態度を続けていくとして、プライベートではもう少し良い言語を学びたいものです。

セブンHDツールプレミアム.xlsm

Sub testIE2()
Dim ws As Worksheet
Dim i, j As Long
Dim countURI, countNextClm As Integer
Dim objIE As InternetExplorer 'IEオブジェクトを準備
Set objIE = CreateObject("Internetexplorer.Application") '新しいIEオブジェクトを作成してセット
Dim el As IHTMLElement
Dim htmlDoc As HTMLDocument 'HTMLドキュメントオブジェクトを準備
Dim colTitle, colTh, colTd, colData, colImg As IHTMLElementCollection 'IHTMLエレメントコレクションを準備
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Cells.Clear

objIE.Visible = False 'IEを表示
countURI = 1

i = 1
For countURI = 0 To 9999
    Debug.Print countURI
    objIE.navigate "https://********.jp/*******/search/detail?id=" & countURI 'IEでURLを開く
    
    Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE '読み込み待ち
        DoEvents
    Loop
    
    Set htmlDoc = objIE.document 'objIEで読み込まれているHTMLドキュメントをセット
    Set colTitle = htmlDoc.getElementsByClassName("headLine1 headLine1-line")
    Set colTh = htmlDoc.getElementsByClassName("itemDetail_td")
    Set colTd = htmlDoc.getElementsByClassName("tag color01")
    Set colData = htmlDoc.getElementsByClassName("itemDetail_leadsTxt")
    Set colImg = htmlDoc.getElementsByClassName("itemDetail_img")
    
    If colTh.Length = 0 Then
        GoTo Continue
    End If
    
    ws.Cells(i, 1).Value = countURI
    ws.Cells(i, 2).Value = colTd(0).innerText
    ws.Cells(i, 3).Value = colTitle(0).innerText
    ws.Cells(i, 4).Value = colImg(0).src
    ws.Cells(i, 5).Value = colData(0).innerText
    
    countNextClm = 6
    For Each el In colTh
        ws.Cells(i, countNextClm).Value = "'" & el.innerText
        countNextClm = countNextClm + 1
    Next el
    i = i + 1
Continue:
Next
End Sub