Excel VBA 逆引き集 | 年次集計

Excel VBA
スポンサーリンク

年次集計

毎年の売上・件数・平均を「年ごと」にまとめるテンプレートを、初心者でも壊さず使えるように整理しました。少量なら関数が最短、大量なら配列＋辞書が爆速、ピボットなら一発です。

選び方の指針

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

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

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

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

    For r = 2 To outLast
        y0 = Range("F" & r).Value                 '年初
        y1 = DateSerial(Year(y0) + 1, 1, 1)       '翌年初（上限）

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

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

Sub YearlySummary_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, yr As String, amt As Double
    For i = 2 To UBound(v, 1)
        yr = Format$(v(i, 1), "yyyy")     '年キー
        amt = Val(v(i, 3))
        If sumMap.Exists(yr) Then
            sumMap(yr) = sumMap(yr) + amt
            cntMap(yr) = cntMap(yr) + 1
        Else
            sumMap.Add yr, amt
            cntMap.Add yr, 1
        End If
    Next

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

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

Sub YearlySummary_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" '年表示
        .PivotFields("金額").Orientation = xlDataField
        .PivotFields("金額").Function = xlSum
        .PivotFields("金額").NumberFormat = "#,##0"
        '必要なら商品や部門を列フィールドに
        '.PivotFields("商品").Orientation = xlColumnField
    End With
End Sub
VB
  • ポイント:
    • ピボットなら「年×カテゴリ」の表を瞬時に作成可能。更新は Refresh だけで済む。

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

Sub YearlySummary_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, yr As String
    For i = 2 To UBound(v, 1)
        yr = Format$(v(i, cDate), "yyyy")
        If sumMap.Exists(yr) Then
            sumMap(yr) = sumMap(yr) + Val(v(i, cAmt))
            cntMap(yr) = cntMap(yr) + 1
        Else
            sumMap.Add yr, Val(v(i, cAmt))
            cntMap.Add yr, 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 YearlySummary_FilterThenSum()
    With Range("A1").CurrentRegion
        '例：2024年（2024/1/1以上、2025/1/1未満）
        .AutoFilter Field:=1, Operator:=xlAnd, Criteria1:=">=1/1/2024", Criteria2:="<1/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
  • ポイント:
    • 前後で停止→復帰を挟むだけで体感速度が改善。失敗時も復帰させる。

よくある落とし穴と対策

  • 日時付きで年が崩れる: 比較は「年初以上かつ翌年初未満」にするか、キーは Format$(date, "yyyy") に丸める。
  • 列順変更で壊れる: 見出し名から列探索して耐久性を上げる（FindHeader）。
  • OR条件（複数カテゴリ）も年次で集約したい: 辞書のキーに「年｜カテゴリ」を連結すれば軸追加できる。
  • セル往復で遅い: 範囲→配列→辞書→一括書き戻しが鉄板。ピボットも有効。
  • 0件で平均がエラー: 分母ゼロチェックで0やエラーを明示的に返す。

例題で練習

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

'例2：辞書で「yyyy」キーの年次合計・件数・平均を一括出力
Sub Example_DictYearly()
    Call YearlySummary_Dictionary
End Sub

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

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