Excel VBA 逆引き集 | 小計行の生成

Excel VBA
スポンサーリンク

小計行の生成

「部署ごと」「商品ごと」などのグループ単位で小計行を差し込むテンプレを、初心者でも壊さず使える形でまとめました。最短はExcelの内蔵「Subtotal」機能、柔軟に見た目を作り込みたいなら自作挿入、大量データは配列で爆速処理が安定です。

選び方の指針

  • 最短・おまかせ: Range.Subtotal（Excelの集計機能をVBAで呼ぶ）
  • 見た目を自在に作る: ループでグループ境界に行を挿入して「小計」行を生成
  • 大量・高速: 配列でグループ集計→一括で小計行を組み立てて書き戻し
  • フィルタ連動: SUBTOTAL関数を使うと「非表示を除外」「ネスト小計の二重計算回避」が簡単

基本テンプレ：Excel内蔵の「Subtotal」を使う（最短）

Sub InsertSubtotals_Builtin()
    '前提：A列がグループキー（例：部署）、D列が合計したい数値（例：金額）
    '表はA1起点のCurrentRegion（見出しあり）
    Dim rg As Range: Set rg = Range("A1").CurrentRegion

    'グループ単位で小計追加（Outlineの+/-で畳める）
    'GroupBy:=1 → 1列目（A列）でグループ化、Function:=xlSum → 合計
    'TotalList:=Array(4) → 4列目（D列）に対して小計（複数列なら配列で列番号を列挙）
    rg.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4), _
                Replace:=True, PageBreaks:=False, SummaryBelow:=True
End Sub
VB
  • ポイント
    • 見出し＋連続範囲が前提: CurrentRegionで表を丸ごと扱うと楽。
    • 複数列の小計: TotalList:=Array(4,5,6) のように列番号を並べる。
    • 種類の変更: Function:=xlCount や xlAverage に差し替え可。
    • グループキー: GroupBy は「範囲内の何列目か」を指定（A列なら1）。

自作テンプレ：グループ境界で「小計」行を挿入（柔軟な見た目）

Sub InsertSubtotals_Custom()
    '前提：A=グループ（部署など）, D=金額。A列で昇順に並んでいると想定
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim r As Long, curKey As String, sumAmt As Double
    Dim startRow As Long: startRow = 2 'データ開始

    curKey = Cells(startRow, "A").Value
    sumAmt = 0

    For r = startRow To last
        Dim key As String: key = Cells(r, "A").Value
        Dim amt As Double: amt = Val(Cells(r, "D").Value)

        If key = curKey Then
            sumAmt = sumAmt + amt
        Else
            'グループ境界→「小計」行を1行挿入
            Rows(r).Insert
            Cells(r, "A").Value = curKey & " 小計"
            Cells(r, "D").Value = sumAmt
            Cells(r, "A").Font.Bold = True
            Cells(r, "D").Font.Bold = True
            '次グループの初期化
            curKey = key
            sumAmt = amt
            r = r + 1 '挿入した分、次のデータ行へ
            last = last + 1
        End If
    Next

    '最後のグループの小計
    Rows(last + 1).Insert
    Cells(last + 1, "A").Value = curKey & " 小計"
    Cells(last + 1, "D").Value = sumAmt
    Cells(last + 1, "A").Font.Bold = True
    Cells(last + 1, "D").Font.Bold = True

    '総合計（任意）
    Rows(last + 2).Insert
    Cells(last + 2, "A").Value = "総合計"
    Cells(last + 2, "D").Formula = "=SUM(D2:D" & last & ")"
    Cells(last + 2, "A").Font.Bold = True
    Cells(last + 2, "D").Font.Bold = True
End Sub
VB
  • ポイント
    • 並び順が重要: A列でグループごとに連続している前提。必要なら Range.Sort で事前ソート。
    • 見た目調整自在: 行挿入位置、見出し文言、書式などを自由に制御可能。
    • 複数指標: E列やF列の小計を同時に出したい場合は同様に加算して書き込み。

爆速版：配列でグループ小計を作ってからまとめて書き戻し

Sub InsertSubtotals_ArrayFast()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Dim rg As Range: Set rg = Range("A1").CurrentRegion 'A=グループ, D=金額
    Dim v As Variant: v = rg.Value

    '前提：A列でソート済み（必要なら先に Sort 実行）
    Dim rowsOut As Collection: Set rowsOut = New Collection

    'ヘッダーをそのまま出力キューへ
    rowsOut.Add Application.Index(v, 1, 0)

    Dim i As Long, curKey As String, sumAmt As Double
    curKey = CStr(v(2, 1)): sumAmt = 0

    For i = 2 To UBound(v, 1)
        Dim key As String: key = CStr(v(i, 1))
        Dim amt As Double: amt = Val(v(i, 4))

        If key = curKey Then
            sumAmt = sumAmt + amt
            rowsOut.Add Application.Index(v, i, 0) '明細行を追加
        Else
            '小計行を追加（行を仮想的に生成）
            rowsOut.Add Array(curKey & " 小計", "", "", sumAmt)
            '次グループ初期化＋明細行追加
            curKey = key: sumAmt = amt
            rowsOut.Add Application.Index(v, i, 0)
        End If
    Next

    '最後のグループの小計行
    rowsOut.Add Array(curKey & " 小計", "", "", sumAmt)

    'コレクション→2次元配列化
    Dim n As Long: n = rowsOut.Count
    Dim out() As Variant: ReDim out(1 To n, 1 To UBound(v, 2))
    For i = 1 To n
        Dim rowA As Variant: rowA = rowsOut(i)
        Dim j As Long
        For j = 1 To UBound(v, 2)
            If IsArray(rowA) Then out(i, j) = IIf(j <= UBound(rowA), rowA(j - 1), "")
            If Not IsArray(rowA) Then out(i, j) = rowA(j) 'ヘッダー行のケース
        Next
    Next

    '元範囲をクリアして上書き
    rg.ClearContents
    rg.Resize(n, UBound(v, 2)).Value = out

    '見た目強調（小計行を太字）
    Dim r As Long
    For r = 2 To n
        If InStr(1, rg.Cells(r, 1).Value, "小計") > 0 Then
            rg.Rows(r).Font.Bold = True
        End If
    Next

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント
    • セル往復ゼロ: 範囲→配列→キュー→一括書き戻しで高速。
    • 列が増えても安定: ヘッダーと明細を丸ごとコピー、必要列だけ加工。

フィルタ連動の小計：SUBTOTAL関数で「可視セルだけ」集計

Sub InsertSubtotals_WithSUBTOTALFormula()
    'グループごとに区切り行を既に挿入済みと仮定（または区切り列で判定）
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row

    Dim r As Long, startRow As Long: startRow = 2
    For r = startRow To last
        '「小計」行の判定（A列が空、もしくは特定ラベル）
        If Cells(r, "A").Value = "小計" Then
            '上のグループ範囲を把握してSUBTOTAL式を設定
            Dim groupStart As Long: groupStart = Cells(r, "B").End(xlUp).Row + 1 '例：B列にデータがあると仮定
            Cells(r, "D").Formula = "=SUBTOTAL(9,D" & groupStart & ":D" & (r - 1) & ")" '9=SUM
            Cells(r, "D").Font.Bold = True
        End If
    Next
End Sub
VB
  • ポイント
    • SUBTOTALの利点: フィルタで非表示の行は自動で除外、さらに入れ子のSUBTOTALを二重計算しない。
    • 関数番号: 9=SUM, 1=AVERAGE, 2=COUNT、用途に応じて切り替え可能。
    • 式→値化: 固定化したいときは .Value = .Value で値にする。

Outline（グループ化）で折りたたみ対応をつける

Sub AddOutlineGroups()
    'A列の連続グループごとにアウトラインを設定（小計行の上までをグループ）
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim r As Long, blockStart As Long: blockStart = 2
    For r = 2 To last
        If InStr(1, Cells(r, "A").Value, "小計") > 0 Then
            Range(Cells(blockStart, 1), Cells(r - 1, 1)).EntireRow.Rows.Group
            blockStart = r + 1
        End If
    Next
    'アウトライン表示設定
    ActiveSheet.Outline.SummaryRow = xlSummaryBelow
End Sub
VB
  • ポイント
    • +/-で畳める: 小計の直前／直後で折りたたみ可能に。
    • SummaryRow: 小計行が「下」か「上」かの表示を制御。

よくある落とし穴と対策

  • ラベル: グループが連続していない
    • 対策: 事前にソート（例：A列昇順）。Range("A1").CurrentRegion.Sort を活用。
  • ラベル: データが文字列で合計できない
    • 対策: Val で数値化、元データの型を正す。必要なら .Value = .Value で値化。
  • ラベル: Builtin Subtotalの列番号を間違える
    • 対策: TotalList:=Array(列番号...) は「範囲内の列番号」。見出し位置を確認。
  • ラベル: 二重に小計が入ってしまう
    • 対策: Builtinは Replace:=True で置き換え。自作挿入は一度クリアしてから生成。
  • ラベル: フィルタ時に数字が合わない
    • 対策: SUBTOTAL関数を採用（可視セルのみ）。固定値ならフィルタ非前提に。
  • ラベル: 行挿入でループがズレる
    • 対策: 末尾から逆ループ、または配列で組み立てて一括書き戻しが安全。

例題で練習

'例1：A列の部署ごとにD列金額の小計をBuiltinで挿入（アウトライン付き）
Sub Example_SubtotalBuiltin()
    Call InsertSubtotals_Builtin
End Sub

'例2：A列の境界で行を挿入して「○○ 小計」＋合計金額を太字で出す
Sub Example_SubtotalCustom()
    Call InsertSubtotals_Custom
End Sub

'例3：10万行規模でも速い、配列で小計行を合成→一括書き戻し
Sub Example_SubtotalArrayFast()
    Call InsertSubtotals_ArrayFast
End Sub

'例4：フィルタに追随する小計（SUBTOTAL式）を設定
Sub Example_SubtotalWithFormula()
    Call InsertSubtotals_WithSUBTOTALFormula
End Sub

'例5：小計ブロックにアウトラインを付与して折りたたみ可能に
Sub Example_AddOutline()
    Call AddOutlineGroups
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました