動作確認環境

• Windows10
• Excel2007
• InternetExplorer11

参照設定

今回はIEを生成し、DOM操作を行い、HTMLから値を取得するので以下の参照設定を追加します。

デフォルト参照設定

• Visual Basic For Applications
• Microsoft Excel **.* Object Library
• OLE Automation
• Microsoft Office **.* Object Library

追加参照設定

• Microsoft HTML Object Library
• Microsoft Innternet Controls

２つの参照にチェックを入れ「OK」を押すと参照が追加されます。

サンプル

サンプルファイルのダウンロード
header モジュール

Option Explicit

''' Sleep
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

functions モジュール

Option Explicit

'''
''' スペース タブ 改行 削除
'''     @param    対象 文字列
'''     @retrun   削除後 文字列
'''
Public Function trimAll(str_ As String)
    trimAll = Replace(Replace(Replace(Replace(Trim(str_), vbCrLf, ""), vbCr, ""), vbLf, ""), vbTab, "")
End Function

scraping モジュール

''' 参照追加
'''     Microsoft HTML Object Library
'''     Microsoft Innternet Controls
'''

Option Explicit

'''
''' scraping
'''
Sub main()

'
' WS 設定値
'
Dim str_urls As String
Dim str_tags As String

' WS 設定取得
With Worksheets("Sheet1")
    str_urls = .Range("B5").Value
    str_tags = .Range("B8").Value
End With

' WS 設定確認
If "" = str_urls Then
    MsgBox ("取得ページURLを入力してください。")
    Exit Sub
End If
If "" = str_tags Then
    MsgBox ("取得タグを入力してください。")
    Exit Sub
End If

' 記入済データ 消去
Sheets("Sheet2").Cells.Clear


'
' 処理開始
'
Dim urls
Dim tags
Dim url_length As Integer
Dim tag_length As Integer
Dim i As Integer, j As Integer
Dim ie As InternetExplorer
Dim tag As HTMLHtmlElement
Dim datas() As String
Dim counter_tag As Integer
Dim counter_max As Integer
Dim result
Dim row As Integer

row = 1
urls = Split(str_urls, vbLf)
tags = Split(str_tags, vbLf)
url_length = UBound(urls)
tag_length = UBound(tags)


' IE 生成
Set ie = CreateObject("InternetExplorer.Application")
With ie
    ' IE 可視化
    .Visible = True
    
    ' URLの数だけ繰り返し
    For i = 0 To url_length
        ' IE 取得用URL
        .navigate urls(i)

        ' IE ページ表示待機
        Sleep 1000
        Do
            Sleep 300
            DoEvents
        Loop Until (Not .Busy) And (.readyState = 4)
        Sleep 1000

        ' 初期化
        counter_max = 0
        ReDim datas(tag_length + 1, 0)
        
        ' タグの数だけ繰り返し
        For j = 0 To tag_length
            counter_tag = 0
            
            ' header行 タグ名表示
            datas(j + 1, counter_tag) = tags(j)

            ' ページ内 全指定タグ取得
            For Each tag In .document.getElementsByTagName(tags(j))

                ' 二次元配列が足りない場合 追加
                If counter_max < counter_tag + 1 Then
                    ReDim Preserve datas(tag_length + 1, counter_tag + 1)
                End If
                datas(j + 1, counter_tag + 1) = trimAll(tag.innerText)

                counter_tag = counter_tag + 1
            Next tag
            
            ' 最大二次元配列数 記憶
            If counter_max < counter_tag Then
                counter_max = counter_tag
            End If
        Next j

        ' 1列目に 取得URL 記入
        For j = 1 To counter_max
            datas(0, j) = urls(i)
        Next j

        ' 取得データ まとめて書き込み
        result = WorksheetFunction.Transpose(datas)
        With Worksheets("Sheet2")
            .Range(.Cells(row, 1), .Cells(row + counter_max, tag_length + 2)) = result
        End With

        ' 次 URL開始 位置 + 1
        row = row + counter_max + 1
    Next i
    
    .Quit
End With
Set ie = Nothing

MsgBox ("取得が完了しました。")
' Sheet2 表示
Worksheets("Sheet2").Activate

End Sub

プログラムの説明

header モジュール

''' Sleep
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

functions モジュール

'''
''' スペース タブ 改行 削除
'''     @param    対象 文字列
'''     @retrun   削除後 文字列
'''
Public Function trimAll(str_ As String)
    trimAll = Replace(Replace(Replace(Replace(Trim(str_), vbCrLf, ""), vbCr, ""), vbLf, ""), vbTab, "")
End Function

scraping モジュール

' WS 設定取得
With Worksheets("Sheet1")
    str_urls = .Range("B5").Value
    str_tags = .Range("B8").Value
End With

' WS 設定確認
If "" = str_urls Then
    MsgBox ("取得ページURLを入力してください。")
    Exit Sub
End If
If "" = str_tags Then
    MsgBox ("取得タグを入力してください。")
    Exit Sub
End If

' 記入済データ 消去
Sheets("Sheet2").Cells.Clear

' IE 生成
Set ie = CreateObject("InternetExplorer.Application")
With ie
    ' IE 可視化
    .Visible = True
    
    ' URLの数だけ繰り返し
    For i = 0 To url_length
        ' IE 取得用URL
        .navigate urls(i)

' 初期化
counter_max = 0
ReDim datas(tag_length + 1, 0)

' タグの数だけ繰り返し
For j = 0 To tag_length

' header行 タグ名表示
datas(j + 1, counter_tag) = tags(j)

' ページ内 全指定タグ取得
For Each tag In .document.getElementsByTagName(tags(j))

    ' 二次元配列が足りない場合 追加
    If counter_max < counter_tag + 1 Then
        ReDim Preserve datas(tag_length + 1, counter_tag + 1)
    End If
    datas(j + 1, counter_tag + 1) = trimAll(tag.innerText)

    counter_tag = counter_tag + 1
Next tag

' 1列目に 取得URL 記入
For j = 1 To counter_max
    datas(0, j) = urls(i)
Next j

' 取得データ まとめて書き込み
result = WorksheetFunction.Transpose(datas)
With Worksheets("Sheet2")
    .Range(.Cells(row, 1), .Cells(row + counter_max, tag_length + 2)) = result
End With

' Sheet2 表示
Worksheets("Sheet2").Activate