価格.comの最安値情報を取得してくるExcelVBAマクロ

久々の更新。

Excel VBAで価格.comの最安値情報を取得してくるマクロのメモ書き。

やりたいこと

選択範囲の型番で価格.comの最安値情報を検索し、同じ行の隣のセルに入力したい。

参照設定

以下を有効にする：

• Microsoft HTML Object Library
• Microsoft Internet Controls
• Microsoft VBScript Reqular Expressions 5.5
• Microsoft Script Control 1.0

クラスモジュール

''
' KakakuComSearchItem
'
' 取得した価格情報を保持しておくためのクラス
'

Public self As HTMLDivElement
Public name As String
Public price As String

Function setItem(element As HTMLDivElement)
    Set self = element
    name = self.getElementsByClassName("itemnameN").item(0).textContent
    price = self.getElementsByClassName("yen").item(0).textContent
    
    ' 価格から余計な文字を取り除く
    Dim regex As New RegExp
    regex.Pattern = "[^0-9]"
    regex.Global = True
    price = regex.Replace(price, "")
End Function

標準モジュール

''
' Module 1
'

' 最安値情報検索URL (%sの部分を実行時に検索語句に置換する)
Const SEARCH_BASE_URL = "http://kakaku.com/search_results/%s"

Sub 価格comの最安値情報取得()
    ' encodeURIComponent関数で検索語句をURLエンコードするためにJSをロード
    Dim js As New ScriptControl
    js.Language = "JScript"
    
    ' 不可視モードでIEを呼び出す
    Dim ie As New InternetExplorer
    ie.Visible = False

    Dim item As New KakakuComSearchItem
    Dim c As Range
    For Each c In Selection
        Set item = searchItem(c.Value, ie, js)
        c.Offset(0, 1).Value = item.name
        c.Offset(0, 2).Value = item.price
    Next

    ' Quitしないとマクロが終了してもIEのプロセスが残り続ける
    ie.Quit
    Set js = Nothing
    Set ie = Nothing
    MsgBox "Finished."
End Sub

Private Function searchItem(word As String, ie As InternetExplorer, js As ScriptControl) As KakakuComSearchItem
    Dim url As String
    url = Replace(SEARCH_BASE_URL, "%s", js.CodeObject.encodeURIComponent(word))
    
    ' 第一引数(url)だけだとGET, 第四引数(body)を含めるとPOSTでリクエストするみたい
    ' sort=priceb&act=Sort の設定が「価格昇順」を意味するっぽい
    ie.navigate url, , , "n=30&l=1&sort=priceb&act=Sort"
    ' 応答あるまで待機
    wait ie
    
    Dim document As HTMLDocument
    Set document = ie.document
    
    Dim item As New KakakuComSearchItem
    If document.getElementsByClassName("item01").Length = 0 Then
        item.name = "該当無し"
        item.price = "該当無し"
    Else
        item.setItem document.getElementsByClassName("item01").item(0)
    End If
    
    Set searchItem = item
End Function

Private Function wait(ie As InternetExplorer)
    Do While ie.Busy = True Or ie.readyState < READYSTATE_COMPLETE
        DoEvents
        sleep 500
    Loop
End Function

Private Function sleep(msec As Long)
    Application.wait [Now()] + msec / 86400000
End Function

以上。