【Excel VBA】複数ブックのデータ（単票）を一覧表にまとめる事例

ExcelのVBAで、複数ブックのデータ（単票）を一覧表にまとめる事例です。Power Queryでの集計が難しい「神エクセル」と言われるような、紙印刷のレイアウトを前提にしたExcelシートをVBAで一覧表にした備忘録。

同じフォーマットで入力されたExcelファイルを大量に回収し、集計するときに活用できるサンプルです。抽出するセルの場所は、Excelの標準機能にある「メモ」で指定します。

内容：

事例の前提
VBAサンプル
事例の実行結果
事例の補足説明
複数ブックのデータ（単票）を一覧表にまとめる方法の比較

事例の前提

次のように、同じレイアウト（単票形式）のExcelファイルに入力されているデータを一覧表にまとめる。

VBAの汎用性を持たせるため、抽出するセルの場所は、Excelの標準機能にある「メモ」を活用し、次のようにする。

「設定シート」で一覧表にまとめた時に項目名にしたい名称を「メモ」で記載し、「出力シート」に一覧表を作成する。
「出力シート」の１行目に、項目名が既にある場合は、その項目名の列にデータを転記する。無い場合は項目を新規追加する。

VBAサンプル

Option Explicit
Option Base 1

    Dim 設定シート As Worksheet, 出力シート As Worksheet
    Dim 対象ファイル名 As Variant, 対象ブック As Workbook
    Dim 項目セル As Range
    Dim 出力行 As Long
    Dim 抽出データ() As String
    Dim i As Long, k As Long


Sub 設定シートのメモ情報でデータの統合()
'初期設定'
    Set 設定シート = ThisWorkbook.Sheets("設定シート")
    Set 出力シート = ThisWorkbook.Sheets("出力シート")
    出力シート.Cells(1, 1).Value = "ファイル名"
              
'ファイルの読み込み'
    対象ファイル名 = Application.GetOpenFilename( _
        FileFilter:="(*.xls; *.xlsx), *.xls; *.xlsx", _
        Title:="読み込むブックを選択して下さい（複数選択可）", _
        MultiSelect:=True)
    If TypeName(対象ファイル名) = "Boolean" Then Exit Sub
        
    Application.ScreenUpdating = False

'設定シートを読み込み、各ブックのデータ移動'
    Call 設定シートの読み込み
    For i = 1 To UBound(対象ファイル名)
        Application.StatusBar = i & " / " & UBound(対象ファイル名) & " ファイル処理中"
             
        Workbooks.Open fileName:=対象ファイル名(i), ReadOnly:=True
        Set 対象ブック = ActiveWorkbook
        Call 各ブックのデータ移動
        対象ブック.Close SaveChanges:=False
    Next i

    Application.StatusBar = False
    Application.ScreenUpdating = True

End Sub

Sub 設定シートの読み込み()
    '抽出データは配列で以下を格納'
    '抽出データ(k, 1) 抽出するセル位置'
    '抽出データ(k, 2) メモの値'
    '抽出データ(k, 3) 出力シートでの列番号'
    
    Dim メモがあるセル As Comment
    ReDim 抽出データ(設定シート.Comments.Count, 3)
    
    k = 1
    For Each メモがあるセル In 設定シート.Comments
            抽出データ(k, 1) = メモがあるセル.Parent.Address
            抽出データ(k, 2) = メモがあるセル.Text 'メモの値で項目を取得'
            
            '出力シートの先頭行で、項目の有無を確認し、列番号の取得'
            Set 項目セル = 出力シート.Rows(1).Find(抽出データ(k, 2), LookIn:=xlValues, LookAt:=xlWhole, MatchByte:=False)
            
            '項目がない場合、最終列に項目を追加'
            If 項目セル Is Nothing Then
                抽出データ(k, 3) = 出力シート.Cells(1, Columns.Count).End(xlToLeft).Column + 1 '出力する列'
                出力シート.Cells(1, CLng(抽出データ(k, 3))) = 抽出データ(k, 2)
            Else
                抽出データ(k, 3) = 項目セル.Column
            End If
            
            k = k + 1
    Next メモがあるセル
End Sub

Private Sub 各ブックのデータ移動()
'1列目のファイル情報の入力結果から最終行を取得'
    出力行 = 出力シート.Cells(Rows.Count, 1).End(xlUp).Row + 1
    出力シート.Cells(出力行, 1).Value = 対象ブック.Name
            
'対象セルの値移動'
    For k = LBound(抽出データ, 1) To UBound(抽出データ, 1)
            出力シート.Cells(出力行, CLng(抽出データ(k, 3))) = ActiveSheet.Range(抽出データ(k, 1)).Value
    Next k

End Sub

二次元配列を使用した事例にしています。可読性が気になる場合は、「抽出データ」を３つに分けて、１次元配列の変数で作成しても良いと思います。