Excel 小計(集計)機能について(3)小計機能を改良するマクロ個人用マクロブックに組み込める

小計機能の改良マクロ

Excel 小計(集計)機能について(2)小計機能のデメリット

2020年3月21日

以前の記事で、Excelの小計(集計)機能についてデメリットを愚痴っぽく書いてしまった。

批判的なことを書くだけではしょうがないので、この小計(集計)機能について、使い勝手を改良するマクロを作ってみたものを記す。

動作条件がちょっとやかましいのだが

マクロの動作条件

集計において「基準」となる列の1行目に「G」の文字を入れることを条件とする。
「G」の文字は2個以上入れることは不可。
したがって、集計する表は、Excelシートの2行目以降から始まっていて、1行目は空けられていることが条件だ。
「G」は「Group」の「G」ね。
集計の「集計する数値フィールド」となる列の1行目に「T」の文字を入れることを条件とする。
「T」は「Total」の「T」ね。
集計の方法は「データの個数」「平均」とかはなく「合計」のみ。

というようになる。

私がマクロを作る時はほとんど、自分の必要に強く駆られてなのだが、なぜこのマクロを作ったのかは後述するので、まずは当該マクロを下に記述する。

Sub anotherSubtotal()
'集計コマンドを、少し改良。
    Dim arr             As Variant
    Dim sumCol          As Variant
    Dim ws              As Worksheet
    Dim totalRng        As Range
    Dim groupCol        As Long
    Dim iniCol          As Long
    Dim endCol          As Long
    Dim c               As Long
    Dim num             As Long
    Dim msg             As String
 
    On Error GoTo theEnd
 
    Set ws = ActiveSheet
 
    msg = "この処理は、1行目に「G」を入れた列を基準列として、"
    msg = msg ＆ vbCrLf ＆ "1行目に「T」を入れた列に集計をかけます。"
    msg = msg ＆ vbCrLf ＆ "よろしければ、集計セル範囲を選択して下さい。"
 
    'セル範囲を指定するメッセージボックス(Type:=8で指定)
    Set totalRng = Application.InputBox(msg, "集計セル範囲", Default:=Selection.Address, Type:=8)
 
    iniCol = totalRng(1).Column
    endCol = totalRng.Columns.Count
 
    arr = Range(ws.Cells(1, iniCol), ws.Cells(1, endCol)).Value
    ReDim sumCol(1 To 1)
 
    For c = 1 To endCol
        Select Case arr(1, c)
            Case "G"
                If groupCol > 0 Then '1個を超えて「G」がある場合
                    MsgBox "「G」を入れた列が2個以上あるので、処理中断します。", vbExclamation, "基準列オーバー"
                    Exit Sub
                End If
                groupCol = c
            Case "T"
                num = num + 1
                ReDim Preserve sumCol(1 To num)
                sumCol(num) = c '集計列に追加
        End Select
    Next c
 
    Call appSet
    totalRng.Subtotal GroupBy:=groupCol, Function:=xlSum, TotalList:=sumCol _
        , Replace:=True, PageBreaks:=False, SummaryBelowData:=True
 
 
    Call appReset
    Exit Sub
 
theEnd: Call appReset
        Exit Sub
End Sub