Excel VBA 逆引き集 | 集計行だけを抽出

Excel VBA
スポンサーリンク

集計行だけを抽出

「小計行だけを別シートに抜き出したい」「アウトラインの小計行をコピーしたい」——Excelの内蔵Subtotalで作った行、カスタムで差し込んだ「○○ 小計」行、SUBTOTAL関数の行など、どのタイプでも抜き出せるテンプレをまとめました。

選び方の指針

  • 内蔵Subtotalで作った小計行: アウトラインやSUBTOTAL式を手掛かりに抽出が最短
  • 自作の「○○ 小計」行: ラベル文字列で判定して抽出
  • フィルタの結果だけ取りたい: 可視セルのみを一括コピー
  • 大量・高速: 配列で条件判定して、抽出配列をまとめて書き出し

最短：ラベルが「小計」を含む行だけ抽出（自作小計行向け）

Sub ExtractRows_ByLabel()
    '前提：A列に「部署名 小計」などのラベルが入っている
    Dim src As Range: Set src = Range("A1").CurrentRegion
    Dim v As Variant: v = src.Value

    Dim out() As Variant
    Dim i As Long, j As Long, cnt As Long
    ReDim out(1 To UBound(v, 1), 1 To UBound(v, 2))

    'ヘッダーコピー
    For j = 1 To UBound(v, 2): out(1, j) = v(1, j): Next
    cnt = 1

    '「小計」を含む行のみ抽出
    For i = 2 To UBound(v, 1)
        If InStr(1, CStr(v(i, 1)), "小計", vbTextCompare) > 0 Then
            cnt = cnt + 1
            For j = 1 To UBound(v, 2): out(cnt, j) = v(i, j): Next
        End If
    Next

    '出力
    With Worksheets("抽出")
        .Cells.Clear
        .Range("A1").Resize(cnt, UBound(v, 2)).Value = out
    End With
End Sub
VB
  • ポイント
    • 柔軟な判定: 「○○ 小計」「小計」など部分一致で拾える。
    • 大量行でも速い: 範囲→配列→抽出配列→一括書き戻し。

内蔵Subtotalの小計行を抽出（アウトライン・SUBTOTAL式で判定）

Sub ExtractRows_BuiltinSubtotal()
    '前提：Range.Subtotalで小計行が挿入済み、表はA1起点
    Dim src As Range: Set src = Range("A1").CurrentRegion
    Dim v As Variant: v = src.Value

    Dim out() As Variant
    Dim i As Long, j As Long, cnt As Long
    ReDim out(1 To UBound(v, 1), 1 To UBound(v, 2))

    'ヘッダー
    For j = 1 To UBound(v, 2): out(1, j) = v(1, j): Next
    cnt = 1

    '判定ロジック例：
    '1) A列に「小計」などの文言が入る場合はそれで判定
    '2) 小計列のセルにSUBTOTAL関数が入っている行を拾う（D列例）
    For i = 2 To UBound(v, 1)
        Dim isSubtotal As Boolean
        isSubtotal = (InStr(1, CStr(v(i, 1)), "小計", vbTextCompare) > 0)

        '式文字列でSUBTOTALを判定（セルに式がある前提）
        If Not isSubtotal Then
            On Error Resume Next
            Dim f As String: f = src.Cells(i, 4).Formula 'D列が小計列の例
            On Error GoTo 0
            If Len(f) > 0 Then
                isSubtotal = (InStr(1, UCase$(f), "SUBTOTAL(") > 0)
            End If
        End If

        If isSubtotal Then
            cnt = cnt + 1
            For j = 1 To UBound(v, 2): out(cnt, j) = v(i, j): Next
        End If
    Next

    With Worksheets("抽出")
        .Cells.Clear
        .Range("A1").Resize(cnt, UBound(v, 2)).Value = out
    End With
End Sub
VB
  • ポイント
    • SUBTOTAL式で確実に判定: Range.Subtotalの出力はSUBTOTAL関数が入ることが多い。
    • 列位置は現場に合わせて差し替え: 小計値がどの列か決めておく。

フィルタを使って「小計行のみ可視化」→可視セルだけコピー

Sub ExtractRows_FilterVisible()
    With Range("A1").CurrentRegion
        'A列に「小計」を含む行だけ表示
        .AutoFilter Field:=1, Criteria1:="=*小計*"

        Dim vis As Range
        On Error Resume Next
        Set vis = .SpecialCells(xlCellTypeVisible) 'ヘッダー含む可視セル
        On Error GoTo 0

        If Not vis Is Nothing Then
            Worksheets("抽出").Cells.Clear
            vis.Copy Destination:=Worksheets("抽出").Range("A1")
        End If

        .AutoFilter '解除
    End With
End Sub
VB
  • ポイント
    • ワイルドカード: 「=小計」で部分一致。見た目確認しながら抽出できる。
    • 見出し行もコピー: 必要なら Offset(1,0) でヘッダー除外して貼る。

SUBTOTAL関数がある行だけ抽出（フィルタ条件に式判定を活用）

Sub ExtractRows_HasSubtotalFormula()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    '一時判定列を追加して「SUBTOTAL含む」をTRUE/FALSEで作る（安全策）
    Dim lastCol As Long: lastCol = rg.Columns.Count
    rg.Columns(lastCol + 1).Cells(1, 1).Value = "SUBTOTAL?"

    Dim r As Long
    For r = 2 To rg.Rows.Count
        rg.Cells(r, lastCol + 1).Value = InStr(1, UCase$(rg.Cells(r, 4).Formula), "SUBTOTAL(") > 0 'D列例
    Next

    'TRUEをフィルタ→可視セルコピー
    With rg.Resize(rg.Rows.Count, rg.Columns.Count + 1)
        .AutoFilter Field:=.Columns.Count, Criteria1:=True
        Dim vis As Range
        On Error Resume Next
        Set vis = .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        If Not vis Is Nothing Then
            Worksheets("抽出").Cells.Clear
            vis.Copy Destination:=Worksheets("抽出").Range("A1")
        End If

        .AutoFilter
    End With

    '判定列を消す（必要なら残してもOK）
    rg.Offset(0, rg.Columns.Count).EntireColumn.Delete
End Sub
VB
  • ポイント
    • 式の有無で確実に抽出: ラベルがないケースでも対応。
    • 判定列を作ってからフィルタ: 実務で使いやすい。

爆速：配列で判定→抽出表を組み立てて一括出力

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

    Dim src As Range: Set src = Range("A1").CurrentRegion
    Dim v As Variant: v = src.Value

    Dim out() As Variant
    Dim i As Long, j As Long, cnt As Long
    ReDim out(1 To UBound(v, 1), 1 To UBound(v, 2))

    'ヘッダー
    For j = 1 To UBound(v, 2): out(1, j) = v(1, j): Next
    cnt = 1

    For i = 2 To UBound(v, 1)
        Dim isSubtotal As Boolean
        'ラベルベース（A列）
        isSubtotal = (InStr(1, CStr(v(i, 1)), "小計", vbTextCompare) > 0)
        '式ベース（例：D列のセルにSUBTOTALが入っている）
        If Not isSubtotal Then
            On Error Resume Next
            Dim f As String: f = src.Cells(i, 4).Formula
            On Error GoTo 0
            If Len(f) > 0 Then isSubtotal = (InStr(1, UCase$(f), "SUBTOTAL(") > 0)
        End If

        If isSubtotal Then
            cnt = cnt + 1
            For j = 1 To UBound(v, 2): out(cnt, j) = v(i, j): Next
        End If
    Next

    With Worksheets("抽出")
        .Cells.Clear
        .Range("A1").Resize(cnt, UBound(v, 2)).Value = out
    End With

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント
    • セル往復ゼロ: 配列判定→一括書き出しで高速。
    • 判定は複合: ラベル／式のどちらでも拾う。

よくある落とし穴と対策

  • 「小計」の表記ゆれで取りこぼす
    • 対策: 前後空白や括弧、記号を Trim・Replace で正規化。判定は部分一致で。
  • SUBTOTAL列の場所が変わる
    • 対策: 事前に見出し名から列番号を取得して安全に参照（Findで列探索）。
  • フィルタで隠れている行までコピーしてしまう
    • 対策: 可視セルのみコピー（SpecialCells）、またはSUBTOTAL関数を使って見た目に追随。
  • 大きい表で遅い
    • 対策: 配列で判定・抽出してから一括書き戻し。前後で画面更新・計算を止める。

例題で練習

'例1：A列に「○○ 小計」ラベルがある行だけ抽出
Sub Example_ByLabel()
    ExtractRows_ByLabel
End Sub

'例2：Range.Subtotalで作った小計行を式判定で抽出
Sub Example_BuiltinSub()
    ExtractRows_BuiltinSubtotal
End Sub

'例3：フィルタで「小計」だけ見せて可視セルをコピー
Sub Example_FilterVisible()
    ExtractRows_FilterVisible
End Sub

'例4：SUBTOTAL式がある行だけ抽出（判定列を使う安全版）
Sub Example_HasSubtotal()
    ExtractRows_HasSubtotalFormula
End Sub

'例5：大量データを配列で高速抽出
Sub Example_ArrayFast()
    ExtractRows_ArrayFast
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました