Excel VBA 逆引き集 | グループ集計

Excel VBA
スポンサーリンク

グループ集計

「部署ごと」「商品ごと」「年月ごと」などのグループ単位で、合計・件数・平均をまとめる定番テンプレを、初心者でも壊れず使える形で整理しました。少量なら関数、柔軟・大量なら配列＋辞書、見た目重視ならピボットが最短です。

選び方の指針

  • 最短・少量: SUMIFS/COUNTIFS/AVERAGEIFS を「キー別」に回す
  • 大量・柔軟: 配列→辞書で「キー→指標」を一括集計（爆速）
  • 見た目で確認しながら: ピボットテーブルで即表化・更新
  • 列順が変わる現場: 見出し名から列番号を取得して安全に処理

基本：関数でグループ集計（部署リストに対して合計・件数・平均）

Sub GroupSummary_WithFunctions()
    '明細：A=部署, B=日付, C=金額
    Dim depR As Range, dateR As Range, amtR As Range
    Set depR = Range("A2:A100000")
    Set dateR = Range("B2:B100000")
    Set amtR  = Range("C2:C100000")

    '部署リスト：F列に部署が並ぶ（F2〜）
    Dim lastOut As Long: lastOut = Cells(Rows.Count, "F").End(xlUp).Row
    Dim r As Long, dept As String

    For r = 2 To lastOut
        dept = Cells(r, "F").Value
        '合計
        Cells(r, "G").Value = Application.WorksheetFunction.SumIfs(amtR, depR, dept)
        '件数
        Cells(r, "H").Value = Application.WorksheetFunction.CountIfs(depR, dept)
        '平均（0件時のエラーを回避）
        On Error Resume Next
        Cells(r, "I").Value = Application.WorksheetFunction.AverageIfs(amtR, depR, dept)
        On Error GoTo 0
    Next
End Sub
VB
  • ポイント
    • 期間で絞る: dateR に「>=開始」「<翌日」など追加すれば月次・年次なども対応可能。
    • OR条件（部署が複数）: 値ごとに関数を回して足し合わせるか、辞書集計へ切り替える。

爆速：辞書で「キー→合計・件数・平均」を一括（大量行向け）

Sub GroupSummary_Dictionary()
    '明細：A=キー（部署など）, B=日付, C=金額
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    '辞書を用意（合計・件数）
    Dim sumMap As Object: Set sumMap = CreateObject("Scripting.Dictionary")
    Dim cntMap As Object: Set cntMap = CreateObject("Scripting.Dictionary")

    Dim i As Long, key As String, amt As Double
    For i = 2 To UBound(v, 1)
        key = Trim$(UCase$(CStr(v(i, 1)))) 'キー正規化（表記揺れ対策）
        amt = Val(v(i, 3))
        If sumMap.Exists(key) Then
            sumMap(key) = sumMap(key) + amt
            cntMap(key) = cntMap(key) + 1
        Else
            sumMap.Add key, amt
            cntMap.Add key, 1
        End If
    Next

    '出力：F=キー, G=合計, H=件数, I=平均
    Dim keys As Variant: keys = sumMap.Keys
    Dim n As Long: n = UBound(keys) + 1
    If n > 0 Then
        Dim out() As Variant: ReDim out(1 To n, 1 To 4)
        For i = 0 To UBound(keys)
            out(i + 1, 1) = keys(i)
            out(i + 1, 2) = sumMap(keys(i))
            out(i + 1, 3) = cntMap(keys(i))
            out(i + 1, 4) = sumMap(keys(i)) / cntMap(keys(i))
        Next
        With Worksheets("集計")
            .Range("F1:I1").Value = Array("キー", "合計", "件数", "平均")
            .Range("F2").Resize(n, 4).Value = out
        End With
    End If
End Sub
VB
  • ポイント
    • 爆速の基本形: 範囲→配列→辞書→一括書き戻し。セル往復をなくす。
    • 軸追加: キーを「部署|yyyymm」など連結すれば「部署×年月」も一撃。

見出し名で列特定して安全にグループ集計（列順変更に強い）

Sub GroupSummary_ByHeaders()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim head As Range: Set head = rg.Rows(1)

    Dim cKey As Long:  cKey  = FindHeader(head, "部署")  'キー列名
    Dim cAmt As Long:  cAmt  = FindHeader(head, "金額")  '集計対象
    If cKey * cAmt = 0 Then MsgBox "見出しが見つかりません": Exit Sub

    Dim v As Variant: v = rg.Value
    Dim sumMap As Object: Set sumMap = CreateObject("Scripting.Dictionary")
    Dim cntMap As Object: Set cntMap = CreateObject("Scripting.Dictionary")

    Dim i As Long, key As String
    For i = 2 To UBound(v, 1)
        key = Trim$(UCase$(CStr(v(i, cKey))))
        If sumMap.Exists(key) Then
            sumMap(key) = sumMap(key) + Val(v(i, cAmt))
            cntMap(key) = cntMap(key) + 1
        Else
            sumMap.Add key, Val(v(i, cAmt))
            cntMap.Add key, 1
        End If
    Next

    Dim rOut As Long: rOut = 2, k As Variant
    With Worksheets("集計")
        .Range("F1:I1").Value = Array("部署", "合計", "件数", "平均")
        For Each k In sumMap.Keys
            .Cells(rOut, "F").Value = k
            .Cells(rOut, "G").Value = sumMap(k)
            .Cells(rOut, "H").Value = cntMap(k)
            .Cells(rOut, "I").Value = sumMap(k) / cntMap(k)
            rOut = rOut + 1
        Next
    End With
End Sub

Private Function FindHeader(ByVal headerRow As Range, ByVal name As String) As Long
    Dim hit As Range
    Set hit = headerRow.Find(What:=name, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindHeader = IIf(hit Is Nothing, 0, hit.Column)
End Function
VB
  • ポイント
    • 列順変更耐性: 見出し名で列探索、壊れない運用に。
    • 出力列名を揃える: 集計表のヘッダーは最初に書いておくと見やすい。

ピボットテーブルでグループ集計を瞬時に表へ

Sub GroupSummary_Pivot()
    Dim src As Range: Set src = Range("A1").CurrentRegion 'A=部署, B=日付, C=金額
    Dim pc As PivotCache, pt As PivotTable
    Dim outWs As Worksheet

    On Error Resume Next
    Set outWs = Worksheets("ピボット")
    If outWs Is Nothing Then
        Set outWs = Worksheets.Add: outWs.Name = "ピボット"
    End If
    On Error GoTo 0

    Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, src)
    Set pt = pc.CreatePivotTable(outWs.Range("A3"), "グループ集計PT")

    With pt
        .PivotFields("部署").Orientation = xlRowField
        With .PivotFields("金額")
            .Orientation = xlDataField
            .Function = xlSum
            .NumberFormat = "#,##0"
        End With
        '必要なら列やフィルタ軸を追加
        '.PivotFields("日付").Orientation = xlColumnField
        '.PivotFields("日付").NumberFormat = "yyyy-mm"
    End With
End Sub
VB
  • ポイント
    • 見た目が強い: すぐ表になる。更新は PivotCache.Refresh で一瞬。
    • 複数指標: 同じ「金額」フィールドを件数・平均に切り替えて追加も可能。

よくある落とし穴と対策

  • ラベル揺れで別集計になる
    • 対策: キーは Trim/UCase で正規化。必要なら半角化や余分な記号の置換も事前対応。
  • 数値が文字列で集計されない
    • 対策: Val で安全に数値化。集計前に .Value = .Value で値化して式を外す。
  • 期間や複数軸で集計したい
    • 対策: 辞書キーを「部署|yyyymm」など連結して多軸化。ピボットなら行×列×値で即対応。
  • セル往復で遅い
    • 対策: 範囲→配列→辞書→一括書き戻し。結果を配列にまとめて貼る。

例題で練習

'例1：部署リスト（F列）に対して合計・件数・平均（関数）
Sub Example_FunctionsGroup()
    Call GroupSummary_WithFunctions
End Sub

'例2：辞書で部署別の合計・件数・平均を爆速出力
Sub Example_DictGroup()
    Call GroupSummary_Dictionary
End Sub

'例3：見出し名で列を特定して安全にグループ集計
Sub Example_ByHeadersGroup()
    Call GroupSummary_ByHeaders
End Sub

'例4：ピボットテーブルでグループ集計を一発作成
Sub Example_PivotGroup()
    Call GroupSummary_Pivot
End Sub
VB

スポンサーリンク
タイトルとURLをコピーしました