インタネットデータを取得して一覧にするマクロ

製品のスペック、価格、メーカなどの情報をインタネットで調べて、一覧表に纏めたいときがあります。地道で手間のかかる作業です。今回は、この作業を半自動化するマクロを紹介します。

作業の流れは

1.WebページのURLを入手します

2.Webページをエクセルで開く

3.エクセルで開いたWebページのデータをファイルに出力します

4.出力されたファイルをもとに、一覧表を作成します

※作業の2～4はマクロがやってくれます。
※一覧表の作成はユーザ定義一覧を作成するマクロを使用します。

画面はこうなります。

画面の操作を紹介します。
1.URLを入力して、「取得」ボタンにて、インタネットデータを表示します。
※画面の８行目以降
2.Webページ全体を取得するのか、ページの中の表だけを取得するのかを指定できます。
2.出力パスボタンにて、ファイルの格納先を指定します。
3.ファイル名に値またはセルアドレスを指定します。ファイル名は「名前_日付」になります。
4.「ファイル出力」ボタンにて、現在表示しているWebデータをエクセルファイルに出力します。

ソースはこうなります。

''************************************************
'画面の「取得」ボタンから呼び出される
'************************************************
Sub GetWebData()

    Dim strUrl As String
    Dim intLastrow As Integer
    Dim strFileName As String
    Dim strPageType As String
 
    If Range("B1").Value = "" Then Exit Sub
 
    strUrl = Range("B1").Value
    strWebTable = Range("B2").Value
    strFileName = Range("B5").Value
 
    If Range("A2").Value = "表のみ" Then
        strPageType = xlAllTables
    Else
        strPageType = xlEntirePage
    End If
 
    intLastrow = Range("C10000").End(xlUp).Row
 
    '既存データをクリア
    If intLastrow > 8 Then
     
        ThisWorkbook.Sheets("GetWebData").Rows("8:" & intLastrow).Delete shift:=xlUp
 
    End If
 
    'Webデータをダウンロードする
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & strUrl, Destination:=Range("$C$8"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = strPageType
        .WebFormatting = xlWebFormattingAll
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
 
    Range("B5").Value = strFileName
 
End Sub

'************************************************
'画面の「ファイル出力」ボタンから呼び出される
'************************************************
Sub CreatWebDataFile()
    Dim objApp As Object     'Excelアプリ
    Dim objBook As Object    'ExcelBook
    Dim objSheets As Object  'ExcelSheets
    Dim strMsg As String     'エラーメッセージ
    Dim strWebDataFileName  As String  '保存Excelファイル
    Dim xlNormal As Integer
 
    Dim intLastrow As Integer

    xlNormal = -4143

    If Range("B4").Value = "" Then Exit Sub
    If Range("B5").Value = "" Then Exit Sub
    If Range("C8").Value = "" Then Exit Sub

    'フルパス付きファイル名
    strWebDataFileName = Range("B4").Value & "\" _
                         & Range("B5") & "_" & _
                         Format(Date, "yyyymmdd")

    intLastrow = Range("C10000").End(xlUp).Row
 
    On Error Resume Next
    Err.Clear

    Set objApp = CreateObject("Excel.Application")

    If Err Then
    'エラー処理
        strMsg = strMsg & "Excelを起動できませんでした" & vbCrLf
        strMsg = strMsg & "Err.Number:" & Err.Number & vbCrLf
        strMsg = strMsg & "Err.Description:" & Err.Description & vbCrLf
    End If

    If strMsg <> "" Then
     
        'エラーメッセージの表示
        MsgBox strMsg, vbCritical, "Excel の作成"
 
    Else
 
        '新規ワークシートを作成
        objApp.Workbooks.Add
     
        '非表示にする
        objApp.Application.Visible = False
     
        '確認ダイアログを表示させない
        objApp.DisplayAlerts = False
     
        Set objBook = objApp.ActiveWorkbook
        Set objSheets = objBook.Worksheets
     
        'シート1のみ残して後は削除
        For i = 2 To objSheets.Count
            objBook.Sheets(i).Delete
        Next
     
        'データをコピーする
        objSheets(1).Range("A1:X" & intLastrow - 8).Value = _
             ThisWorkbook.Sheets("GetWebData").Range("C8:Z" & intLastrow).Value
           
        '新規ブックを保存
        objBook.SaveAs Filename:=strWebDataFileName, _
                        FileFormat:=xlNormal, _
                        Password:="", _
                        WriteResPassword:="", _
                        ReadOnlyRecommended:=False, _
                        CreateBackup:=False

        'Excelの終了
        objApp.DisplayAlerts = True        '確認ダイアログを表示させる
        objBook.Close
        objApp.Quit
     
        'オブジェクトの解放
        Set objSheet = Nothing
        Set objSheets = Nothing
        Set objBook = Nothing
        Set objApp = Nothing
        'エラーメッセージの表示
        MsgBox "ファイルを作成しました。", vbInformation, "Excelの作成"

    End If

End Sub

----------

以上