🔄
CalculateSubtotals
データ処理A列のグループごとにB列の値の小計を計算して新しいシートに出力します
指定したキー列の値でデータをグループ分けし、各グループの小計を自動計算して新しいシートに一覧表示するマクロです。SUBTOTAL関数やピボットテーブルの設定が苦手な方でも、ワンクリックで集計結果を得られます。グループ化の基準となる列番号と集計する数値列を選ぶだけで、「グループ名・小計」の見やすい一覧表が自動生成されます。月次売上集計・部門別経費集計・商品カテゴリ別在庫合計など、定期的な集計業務の効率化に最適です。集計はグループごとに合計を積み上げる方式のため、データが数千行あっても高速に完了します。結果が新規シートに出るので、元データを汚さずに何度でも条件を変えて試せるのも実務では大きな利点です。集計前にTrimSpacesやNormalizeDataで表記ゆれを整えておくと、同じグループが別々に集計されてしまうミスを防げます。
📖 使い方
- VBAエディタを開く（Alt + F11）
- モジュールを挿入（挿入 > モジュール）
- 下記VBAコードをコピー&ペースト
- ブック上で実行（Alt + F8 でマクロ選択）
💡 実行例： A列にグループ名、B列に数値があるシートで CalculateSubtotals を実行します
🎯 活用シーン
- ✓月次売上データを担当者別・地域別にグループ化して小計レポートを素早く作成したいとき
- ✓経費精算シートを部門別に集計し、予算管理レポートを自動生成したいとき
- ✓商品在庫リストをカテゴリ別に小計して、発注判断のための集計表を作りたいとき
- ✓日次の売上明細を月末にまとめて担当者別の実績表を作成し、評価資料の集計時間を短縮したいとき
- ✓イベントの申込データを部門・チーム別に人数集計して、当日の受付リストを準備したいとき
💡 実装のヒント
- ▸グループ化に使う列には、同じ値が複数行にわたって存在するデータ（部門名・商品分類など）を指定してください。
- ▸集計結果は新規シートに出力されるため、元データを変更せずに結果だけを確認・印刷できます。
- ▸元データの並び順に関係なく、同じグループの値を自動的にまとめて集計するため、事前のソートは不要です。
- ▸「東京」と「東京 」（末尾スペース）は別グループとして集計されます。事前にTrimSpacesを実行しておくと正確です。
- ▸出力された小計シートをそのままSortDataで金額順に並び替えれば、ランキング形式のレポートが完成します。
💻 VBAコード
' CalculateSubtotals
' -----------------
' Macro Name: CalculateSubtotals
' Description: A列のグループごとにB列の値の小計を計算して新しいシートに出力します
' Parameters: なし
' Returns: なし
' Usage: A列にグループ名、B列に数値があるシートで CalculateSubtotals を実行します
' -----------------
Sub CalculateSubtotals()
On Error GoTo ErrorHandler
Dim ws As Worksheet
Dim destWs As Worksheet
Dim lastRow As Long
Dim i As Long
Dim groupKey As String
Dim subtotals As Object
Dim k As Variant
Dim destRow As Long
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then
MsgBox "データが見つかりません（A列: グループ名、B列: 数値）", vbCritical, "エラー"
Exit Sub
End If
Set subtotals = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
groupKey = CStr(ws.Cells(i, 1).Value)
If groupKey <> "" Then
If subtotals.Exists(groupKey) Then
subtotals(groupKey) = subtotals(groupKey) + ws.Cells(i, 2).Value
Else
subtotals.Add groupKey, ws.Cells(i, 2).Value
End If
End If
Next i
Set destWs = Worksheets.Add
destWs.Name = "小計_" & Format(Now, "hhmmss")
destWs.Cells(1, 1).Value = "グループ"
destWs.Cells(1, 2).Value = "小計"
destRow = 2
For Each k In subtotals.Keys
destWs.Cells(destRow, 1).Value = k
destWs.Cells(destRow, 2).Value = subtotals(k)
destRow = destRow + 1
Next k
MsgBox subtotals.Count & " グループの小計を計算しました", vbInformation, "完了"
Exit Sub
ErrorHandler:
MsgBox "エラーが発生しました:" & vbCrLf & Err.Description, vbCritical, "エラー"
End Sub