Excel VBA 逆引き集 | 月次集計

Excel VBA
スポンサーリンク

月次集計

毎月の売上・件数・平均を「年月ごと」にまとめる定番テンプレを、初心者でも壊さず使える形で整理しました。少量なら関数が最短、大量なら配列＋辞書が爆速、ピボットなら一発です。運用の現場に合わせて選べます。

選び方の指針

  • 最短・少量: SUMIFS/COUNTIFS/AVERAGEIFS を「当月範囲」で回す（年月の境界で安定）。
  • 大量・柔軟: 範囲→配列→辞書で「yyyy-mm」キー集計（高速・頑丈）。
  • 見た目で確認しながら: AutoFilterで月範囲抽出→Sum/Count。
  • 一発で表にしたい: ピボットテーブルで「年月×カテゴリー」集計。

基本：SUMIFS/COUNTIFS/AVERAGEIFSで月別集計（当月のみ抽出）

Sub MonthlySummary_Functions()
    '明細：A=日付(時刻付きOK), B=商品, C=金額
    Dim dateR As Range, amtR As Range
    Set dateR = Range("A2:A100000")
    Set amtR  = Range("C2:C100000")

    '集計側：F列に「月初日」が並んでいる（例：2025/01/01, 2025/02/01…）
    Dim outLast As Long: outLast = Cells(Rows.Count, "F").End(xlUp).Row
    Dim r As Long, d0 As Date, d1 As Date

    For r = 2 To outLast
        d0 = Range("F" & r).Value              '月初
        d1 = DateAdd("m", 1, d0)               '翌月初（上限）

        '合計（当月のみ）
        Range("G" & r).Value = Application.WorksheetFunction.SumIfs( _
                                amtR, dateR, ">=" & CLng(d0), dateR, "<" & CLng(d1))
        '件数
        Range("H" & r).Value = Application.WorksheetFunction.CountIfs( _
                                dateR, ">=" & CLng(d0), dateR, "<" & CLng(d1))
        '平均（0件対策はOn Errorでガード）
        On Error Resume Next
        Range("I" & r).Value = Application.WorksheetFunction.AverageIfs( _
                                amtR, dateR, ">=" & CLng(d0), dateR, "<" & CLng(d1))
        On Error GoTo 0
    Next
End Sub
VB
  • ポイント: 月の範囲は「月初以上かつ翌月初未満」で切ると、時刻付きデータでも確実に当月だけを集計できる。月リストがあれば任意区間も簡単に回せる。

爆速：配列＋辞書で「yyyy-mm」キーに月次集計

Sub MonthlySummary_Dictionary()
    '明細：A=日付(時刻付きOK), 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, ym As String, amt As Double
    For i = 2 To UBound(v, 1)
        ym = Format$(v(i, 1), "yyyy-mm") '年月キー（時刻付きでもOK）
        amt = Val(v(i, 3))
        If sumMap.Exists(ym) Then
            sumMap(ym) = sumMap(ym) + amt
            cntMap(ym) = cntMap(ym) + 1
        Else
            sumMap.Add ym, amt
            cntMap.Add ym, 1
        End If
    Next

    '出力：F=年月、G=合計、H=件数、I=平均
    Dim keys As Variant: keys = sumMap.Keys
    If UBound(keys) >= 0 Then
        Dim iOut As Long, out() As Variant
        ReDim out(1 To UBound(keys) + 1, 1 To 4)
        For iOut = 0 To UBound(keys)
            out(iOut + 1, 1) = keys(iOut)
            out(iOut + 1, 2) = sumMap(keys(iOut))
            out(iOut + 1, 3) = cntMap(keys(iOut))
            out(iOut + 1, 4) = sumMap(keys(iOut)) / cntMap(keys(iOut))
        Next
        With Worksheets("月次集計")
            .Range("F1:I1").Value = Array("年月", "合計", "件数", "平均")
            .Range("F2").Resize(UBound(out, 1), UBound(out, 2)).Value = out
        End With
    End If
End Sub
VB
  • ポイント: 10万行規模でも、配列→辞書の組み合わせは非常に速い。年月キーは Format$(日付,"yyyy-mm") が安全。グループ軸を増やす場合はキーに「|」で連結すれば拡張できる。

ピボットテーブルで月次集計を一発作成・更新

Sub MonthlySummary_Pivot()
    Dim src As Range: Set src = Range("A1").CurrentRegion 'A=日付, B=商品, C=金額
    Dim pc As PivotCache, pt As PivotTable
    Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, src)
    Set pt = pc.CreatePivotTable(TableDestination:=Worksheets("月次ピボット").Range("A3"), TableName:="月次PT")

    With pt
        .PivotFields("日付").Orientation = xlRowField
        .PivotFields("日付").NumberFormat = "yyyy-mm" '年月表示（グループでも可）
        .PivotFields("金額").Orientation = xlDataField
        .PivotFields("金額").Function = xlSum
        .PivotFields("金額").NumberFormat = "#,##0"
        '必要なら商品を列フィールドに
        '.PivotFields("商品").Orientation = xlColumnField
    End With
End Sub
VB
  • ポイント: ピボットなら「年月×カテゴリ」の表を瞬時に作れる。更新はピボットキャッシュの Refresh だけで済むため、定期運用と相性が良い。

見出し名で列特定→月次集計（列順変更に強い）

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

    Dim cDate As Long: cDate = FindHeader(head, "日付")
    Dim cAmt  As Long: cAmt  = FindHeader(head, "金額")
    If cDate * 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, ym As String
    For i = 2 To UBound(v, 1)
        ym = Format$(v(i, cDate), "yyyy-mm")
        If sumMap.Exists(ym) Then
            sumMap(ym) = sumMap(ym) + Val(v(i, cAmt))
            cntMap(ym) = cntMap(ym) + 1
        Else
            sumMap.Add ym, Val(v(i, cAmt))
            cntMap.Add ym, 1
        End If
    Next

    Dim k As Variant, rOut As Long: rOut = 2
    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 MonthlySummary_FilterThenSum()
    With Range("A1").CurrentRegion
        '例：2025年1月（1/1以上、2/1未満）
        .AutoFilter Field:=1, Operator:=xlAnd, Criteria1:=">=1/1/2025", Criteria2:="<2/1/2025"

        Dim vis As Range, sumAmt As Double, cnt As Long
        On Error Resume Next
        Set vis = .Columns(3).SpecialCells(xlCellTypeVisible) '金額列(C列)
        On Error GoTo 0
        If Not vis Is Nothing Then
            sumAmt = Application.WorksheetFunction.Sum(vis)
            cnt = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Count
        End If

        Range("G2").Value = sumAmt
        Range("H2").Value = cnt
        Range("I2").Value = IIf(cnt > 0, sumAmt / cnt, 0)
        .AutoFilter
    End With
End Sub
VB
  • ポイント: 目視で確認しながら結果も欲しいときに便利。解除忘れに注意。

大量データの安全・高速ラップ

Sub SafeWrapStart()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Sub SafeWrapEnd()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント: 前後で停止→復帰を挟むだけで体感速度が改善。エラー時も必ず復帰させる。

よくある落とし穴と対策

  • 日時付きで月が崩れる: Date型のまま比較すると境界で漏れが出る。月初以上かつ翌月初未満で切るか、キーは Format$(date,"yyyy-mm") に丸める。
  • 列順変更で壊れる: 見出し名で列探索して耐久性を上げる（FindHeader）。
  • OR条件（複数カテゴリ）を月次で集約したい: 辞書のキーに「年月｜カテゴリ」を連結すれば一発で軸追加。
  • セル往復で遅い: 範囲→配列→辞書→一括書き戻しが鉄板。ピボットも有効。

例題で練習

'例1：月初リスト(F列)に対してSUMIFS/COUNTIFS/AVERAGEIFSで月次指標
Sub Example_FunctionsMonthly()
    Call MonthlySummary_Functions
End Sub

'例2：辞書で「yyyy-mm」キーの月次合計・件数・平均を一括出力
Sub Example_DictMonthly()
    Call MonthlySummary_Dictionary
End Sub

'例3：見出し名で列を見つけて月次集計（列順変更に強い）
Sub Example_ByHeadersMonthly()
    Call MonthlySummary_ByHeaders
End Sub

'例4：ピボットテーブルで月次集計を作成・更新
Sub Example_PivotMonthly()
    Call MonthlySummary_Pivot
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました