【Excel VBA】複数ブックのデータ（単票）をセル位置変更があっても一覧表にまとめた事例

ExcelのVBAで、複数ブックのデータ（単票）をセル位置変更があっても一覧表にする事例。

前回の「【Excel VBA】複数ブックのデータ（単票）を一覧表にまとめる事例」は、同じフォーマットのExcelファイルが前提でした。

しかし、様式変更による項目追加などでフォーマットが変更され、抽出したいセル位置も変更となることはあります。

このような場合でも一覧表にまとめた事例として、「メモ」の情報を活用したVBA備忘録。もちろん、データ収集の段階で集計しやすい回収方法に変更できることが理想的ですが、解決手段の選択肢として紹介。

なお、今回の方法は、フォーマットを発行する側で、記入者に「メモ」を削除させない管理ができる立場でないと有効な方法となりません。

内容：

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

事例の前提

次のように、様式変更により抽出するセル位置が変更になっても、同じ項目は一つの列として一覧表にまとめたい。

（事例では、各ブックで日付データのセル位置は「上側：$C$2、左下：$D$3、右下：$C$3」で異なる。また、フォームの項目も一部異なる）。

そのため、Excelのメモ機能で、抽出したいセルに項目名のメモを追加し、「メモがあるセル位置」「メモの内容」で一覧表にまとめる。

（メモがある場所は、各セルの右上に赤い三角あり）

VBAサンプル

Option Explicit
Option Base 1

    Dim 出力シート As Worksheet
    Dim 対象ファイル名 As Variant, 対象ブック As Workbook
    Dim 項目名 As String, 出力値 As String
    Dim 項目セル As Range
    Dim 出力行 As Long, 出力列 As Long
    Dim i As Long

Sub メモ情報でデータの統合()
'初期設定'
    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

    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

Private Sub 各ブックのデータ移動()
'1列目のファイル情報の入力結果から出力行を取得'
    出力行 = 出力シート.Cells(Rows.Count, 1).End(xlUp).Row + 1
    出力シート.Cells(出力行, 1).Value = 対象ブック.Name
            
'メモのあるセルを検索して値の移動'
    Dim メモがあるセル As Comment
    For Each メモがあるセル In ActiveSheet.Comments
    
        項目名 = メモがあるセル.Text 'メモの値'
        出力値 = メモがあるセル.Parent.Value 'セルの値'
        
        '出力シートの先頭行で、項目の有無を確認し、列番号の取得'
        ThisWorkbook.Activate
        Set 項目セル = 出力シート.Rows(1).Find(項目名, LookIn:=xlValues, LookAt:=xlWhole, MatchByte:=False)
       
        '項目がない場合、最終列に項目を追加'
        If 項目セル Is Nothing Then
            出力列 = Cells(1, Columns.Count).End(xlToLeft).Column + 1
            出力シート.Cells(1, 出力列) = 項目名
        Else
            出力列 = 項目セル.Column
        End If
       
        '項目のある列の最終行にデータを入力'
       出力シート.Cells(出力行, 出力列) = 出力値
        
    Next

End Sub