Excel VBA 逆引き集 | 集約表の統合

Excel VBA
スポンサーリンク

集約表の統合

「部署別・月次別などの“集約済み表”が複数シートや複数ブックに散らばっている。ひとつの総合表にまとめたい」——初心者でも壊れないテンプレを、同一レイアウトの縦結合、見出し名で列合わせ、キーで横結合、複数ブックの一括取り込み、再集計まで含めて整理しました。

使い分けの指針

  • 同じ見出し・同じ列順の表を縦にまとめる: シンプルな縦結合テンプレ（速い・堅い）
  • 列順が違う／列名が揺れる表を統一してまとめる: 見出し名で列合わせテンプレ（壊れにくい）
  • キー（例：部署・年月）で列を横に突き合わせる: マージ（左結合・フル結合）の辞書テンプレ
  • 複数ブック・複数シートから自動収集: Dirループ＋安全ラップで一括取込
  • 集約済みの総合表をさらに再集計: 総計・小計・ピボットの仕上げ

同一レイアウトの表を縦に結合（最短・高速）

Sub AppendTables_SameSchema()
    '各シートのA1からのCurrentRegion（見出しあり）を縦結合して「総合」へ
    Dim wsOut As Worksheet
    On Error Resume Next
    Set wsOut = Worksheets("総合")
    If wsOut Is Nothing Then Set wsOut = Worksheets.Add: wsOut.Name = "総合"
    On Error GoTo 0
    wsOut.Cells.Clear

    Dim ws As Worksheet, rOut As Long: rOut = 1
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsOut.Name Then
            Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
            If rOut = 1 Then
                'ヘッダー＋データ
                wsOut.Range("A1").Resize(rg.Rows.Count, rg.Columns.Count).Value = rg.Value
                rOut = rg.Rows.Count + 1
            Else
                'ヘッダーを除いたデータのみ
                wsOut.Range("A" & rOut).Resize(rg.Rows.Count - 1, rg.Columns.Count).Value = rg.Offset(1, 0).Resize(rg.Rows.Count - 1, rg.Columns.Count).Value
                rOut = rOut + rg.Rows.Count - 1
            End If
        End If
    Next

    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 同一見出し・同一列順の表ならこれで十分。
    • 最初のシートでヘッダーを採用、それ以降はデータだけ追記。

見出し名で列を合わせて縦結合（列順が違っても壊れない）

Sub AppendTables_ByHeaders()
    '全シートのCurrentRegionを「総合」へ、見出し名で列合わせ（欠損列は空欄）
    Dim wsOut As Worksheet
    On Error Resume Next
    Set wsOut = Worksheets("総合")
    If wsOut Is Nothing Then Set wsOut = Worksheets.Add: wsOut.Name = "総合"
    On Error GoTo 0
    wsOut.Cells.Clear

    '総合の標準見出しを定義（必要な列名の並び）
    Dim headers As Variant
    headers = Array("部署", "年月", "合計", "件数", "平均")
    wsOut.Range("A1").Resize(1, UBound(headers) + 1).Value = headers

    Dim rOut As Long: rOut = 2
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsOut.Name Then
            Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
            Dim head As Range: Set head = rg.Rows(1)

            '見出し→列インデックス辞書
            Dim idx As Object: Set idx = CreateObject("Scripting.Dictionary")
            Dim c As Long
            For c = 1 To rg.Columns.Count
                idx(CStr(head.Cells(1, c).Value)) = c
            Next

            Dim r As Long, outRow As Variant
            For r = 2 To rg.Rows.Count
                ReDim outRow(0 To UBound(headers))
                Dim k As Long
                For k = 0 To UBound(headers)
                    Dim h As String: h = CStr(headers(k))
                    If idx.Exists(h) Then
                        outRow(k) = rg.Cells(r, idx(h)).Value
                    Else
                        outRow(k) = "" '欠損列は空欄
                    End If
                Next
                wsOut.Range("A" & rOut).Resize(1, UBound(headers) + 1).Value = outRow
                rOut = rOut + 1
            Next
        End If
    Next

    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 列順・一部列欠損のシートが混在しても安全に統合。
    • 標準見出しの並びを先に決めておくと、後工程が楽。

キーで横に統合（左結合・フル結合の考え方）

左結合（例：基準「部署×年月」に対して、他表の指標列を横付け）

Sub MergeByKeys_LeftJoin()
    '基準表: Sheet("基準") A=部署, B=年月, C=基準合計
    '追加表: Sheet("他指標") A=部署, B=年月, C=他合計
    '出力: Sheet("統合")
    Dim wsBase As Worksheet: Set wsBase = Worksheets("基準")
    Dim wsOther As Worksheet: Set wsOther = Worksheets("他指標")
    Dim wsOut As Worksheet
    On Error Resume Next
    Set wsOut = Worksheets("統合")
    If wsOut Is Nothing Then Set wsOut = Worksheets.Add: wsOut.Name = "統合"
    On Error GoTo 0
    wsOut.Cells.Clear
    wsOut.Range("A1:D1").Value = Array("部署", "年月", "基準合計", "他合計")

    '他指標の辞書（キー=部署|年月 → 値=他合計）
    Dim rgO As Range: Set rgO = wsOther.Range("A1").CurrentRegion
    Dim vO As Variant: vO = rgO.Value
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i As Long, key As String
    For i = 2 To UBound(vO, 1)
        key = Trim$(CStr(vO(i, 1))) & "|" & Trim$(CStr(vO(i, 2)))
        dict(key) = vO(i, 3)
    Next

    '基準をなめて出力、辞書にあれば横付け
    Dim rgB As Range: Set rgB = wsBase.Range("A1").CurrentRegion
    Dim vB As Variant: vB = rgB.Value
    Dim rOut As Long: rOut = 2
    For i = 2 To UBound(vB, 1)
        key = Trim$(CStr(vB(i, 1))) & "|" & Trim$(CStr(vB(i, 2)))
        wsOut.Cells(rOut, 1).Value = vB(i, 1)        '部署
        wsOut.Cells(rOut, 2).Value = vB(i, 2)        '年月
        wsOut.Cells(rOut, 3).Value = vB(i, 3)        '基準合計
        wsOut.Cells(rOut, 4).Value = IIf(dict.Exists(key), dict(key), 0) '他合計（なければ0）
        rOut = rOut + 1
    Next

    wsOut.Columns.AutoFit
End Sub
VB
  • ポイント
    • 基準に存在しないキーは無視（左結合）。不足指標は0や空欄で補完。
    • フル結合にしたい場合は「他指標のキーで基準にないもの」を後から追記。

複数ブックから総合表を作る（フォルダ内一括取り込み）

Sub AppendFromFolder_SameSchema()
    'フォルダ内のxlsxを開いて、各ブックの「集計」シートA1のCurrentRegionを縦結合
    Dim folder As String: folder = "C:\Data\集約"
    Dim f As String: f = Dir(folder & "\*.xlsx")
    Dim wsOut As Worksheet
    On Error Resume Next
    Set wsOut = Worksheets("総合")
    If wsOut Is Nothing Then Set wsOut = Worksheets.Add: wsOut.Name = "総合"
    On Error GoTo 0
    wsOut.Cells.Clear

    Dim rOut As Long: rOut = 1
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Do While Len(f) > 0
        Dim wb As Workbook: Set wb = Workbooks.Open(folder & "\" & f, ReadOnly:=True)
        On Error Resume Next
        Dim ws As Worksheet: Set ws = wb.Worksheets("集計")
        On Error GoTo 0
        If Not ws Is Nothing Then
            Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
            If rOut = 1 Then
                wsOut.Range("A1").Resize(rg.Rows.Count, rg.Columns.Count).Value = rg.Value
                rOut = rg.Rows.Count + 1
            Else
                wsOut.Range("A" & rOut).Resize(rg.Rows.Count - 1, rg.Columns.Count).Value = rg.Offset(1, 0).Resize(rg.Rows.Count - 1, rg.Columns.Count).Value
                rOut = rOut + rg.Rows.Count - 1
            End If
        End If
        wb.Close SaveChanges:=False
        f = Dir() '次のファイル
    Loop

    wsOut.Columns.AutoFit

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント
    • フォルダ内の全ブックを対象に一発で集約。
    • シート名・範囲を現場に合わせて変更。読み込み専用で安全。

統合後の再集計（総合計・ピボット・書式）

Sub PostAggregate_Finish()
    Dim ws As Worksheet: Set ws = Worksheets("総合")
    Dim last As Long: last = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    '総合計行
    ws.Cells(last + 1, 1).Value = "総合計"
    ws.Cells(last + 1, 3).Formula = "=SUM(C2:C" & last & ")" '合計列がCの例
    ws.Rows(1).Font.Bold = True
    ws.Columns.AutoFit
End Sub
VB
  • ポイント
    • 仕上げの総合計や太字・幅調整で「使えるレポート」に。

よくある落とし穴と対策

  • 列順がバラバラで崩れる
    • 対策: 見出し名で列合わせ（AppendTables_ByHeaders）。欠損は空欄補完。
  • キーの表記揺れでマージ失敗
    • 対策: キーは Trim/UCase で正規化。必要なら半角化や置換表を事前適用。
  • 数値が文字列で総合計がズレる
    • 対策: Valで数値化してから合算。式は .Value = .Value で値化。
  • 大量ファイルで遅い／フリーズ
    • 対策: 前後で ScreenUpdating/Calculation/Events を停止→復帰。読み取り専用で開閉。
  • ヘッダー重複や欠損
    • 対策: 統合の標準見出しを決める。ヘッダー行は最初の表から採用し、以降はデータのみ。

例題で練習

'例1：同一レイアウトの各シートを縦結合して「総合」へ
Sub Example_AppendSame()
    AppendTables_SameSchema
End Sub

'例2：見出し名で列合わせして縦結合（列順が違っても安全）
Sub Example_AppendByHeaders()
    AppendTables_ByHeaders
End Sub

'例3：部署×年月キーで他指標を左結合して横に統合
Sub Example_MergeLeft()
    MergeByKeys_LeftJoin
End Sub

'例4：フォルダ内のブックから「集計」シートを集約して総合表へ
Sub Example_FolderAppend()
    AppendFromFolder_SameSchema
End Sub

'例5：統合後に総合計行と書式を付ける
Sub Example_PostFinish()
    PostAggregate_Finish
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました