Excel VBA 逆引き集 | 部署別集計

Excel VBA
スポンサーリンク

部署別集計

部署ごとに「合計」「件数」「平均」をまとめる定番テンプレを、初心者でも壊さず使える形で整理しました。少量なら関数が最短、大量なら配列＋辞書が爆速、見出し名で列特定すれば列順変更にも強いです。

選び方の指針

  • 最短・少量: WorksheetFunctionのSUMIFS/COUNTIFS/AVERAGEIFSで部署別に回す
  • 大量・柔軟: 範囲→配列→辞書で「部署」キー集計（高速・拡張自在）
  • 見た目で確認しながら: AutoFilterで部署を絞って合計や件数
  • 列順が変わる現場: 見出し名から列番号を取得して安全に処理
  • 部署ごとにシート分割もしたい: 部署名で行を振り分けるテンプレ

基本：SUMIFS/COUNTIFS/AVERAGEIFSで部署別集計

Sub DeptSummary_WithFunctions()
    '明細：A=部署, B=日付, C=金額
    Dim depR As Range, dateR As Range, amtR As Range
    Set depR = Range("A2:A100000")
    Set dateR = Range("B2:B100000")
    Set amtR  = Range("C2:C100000")

    '部署リスト（集計先）：F2:F に部署名が並ぶ想定
    Dim outLast As Long: outLast = Cells(Rows.Count, "F").End(xlUp).Row
    Dim r As Long, dept As String

    For r = 2 To outLast
        dept = Range("F" & r).Value
        '合計
        Range("G" & r).Value = Application.WorksheetFunction.SumIfs(amtR, depR, dept)
        '件数
        Range("H" & r).Value = Application.WorksheetFunction.CountIfs(depR, dept)
        '平均（0件対策はOn Errorでガード）
        On Error Resume Next
        Range("I" & r).Value = Application.WorksheetFunction.AverageIfs(amtR, depR, dept)
        On Error GoTo 0
    Next
End Sub
VB
  • ポイント:
    • 部署のOR条件が必要なら: 部署ごとにループして合算するか、辞書集計へ切り替える。
    • 期間で絞りたい: dateRに「>=開始」「<翌日」など条件を追加すればOK。

爆速：配列＋辞書で「部署→合計・件数・平均」

Sub DeptSummary_Dictionary()
    '明細：A=部署, 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, key As String, amt As Double
    For i = 2 To UBound(v, 1)
        key = Trim$(UCase$(CStr(v(i, 1))))    '部署キー（大小文字揺れ対策）
        amt = Val(v(i, 3))
        If sumMap.Exists(key) Then
            sumMap(key) = sumMap(key) + amt
            cntMap(key) = cntMap(key) + 1
        Else
            sumMap.Add key, amt
            cntMap.Add key, 1
        End If
    Next

    '出力：F=部署、G=合計、H=件数、I=平均
    Dim keys As Variant: keys = sumMap.Keys
    Dim n As Long: n = UBound(keys) + 1
    If n > 0 Then
        Dim out() As Variant: ReDim out(1 To n, 1 To 4)
        For i = 0 To UBound(keys)
            out(i + 1, 1) = keys(i)
            out(i + 1, 2) = sumMap(keys(i))
            out(i + 1, 3) = cntMap(keys(i))
            out(i + 1, 4) = sumMap(keys(i)) / cntMap(keys(i))
        Next
        With Worksheets("部署集計")
            .Range("F1:I1").Value = Array("部署", "合計", "件数", "平均")
            .Range("F2").Resize(n, 4).Value = out
        End With
    End If
End Sub
VB
  • ポイント:
    • 型揺れ対策: 部署名は UCase＋Trim で正規化してキー化。
    • 軸追加（部署×年月など）: キーを "部署|yyyymm" のように連結すれば拡張可能。

見出し名で列特定→部署別集計（列順変更に強い）

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

    Dim cDept As Long: cDept = FindHeader(head, "部署")
    Dim cAmt  As Long: cAmt  = FindHeader(head, "金額")
    If cDept * 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, key As String
    For i = 2 To UBound(v, 1)
        key = Trim$(UCase$(CStr(v(i, cDept))))
        If sumMap.Exists(key) Then
            sumMap(key) = sumMap(key) + Val(v(i, cAmt))
            cntMap(key) = cntMap(key) + 1
        Else
            sumMap.Add key, Val(v(i, cAmt))
            cntMap.Add key, 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 DeptSummary_FilterThenSum()
    With Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="営業" '部署で絞る

        Dim visAmt As Range, sumAmt As Double, cnt As Long
        On Error Resume Next
        Set visAmt = .Columns(3).SpecialCells(xlCellTypeVisible) '金額列(C)
        On Error GoTo 0

        If Not visAmt Is Nothing Then
            sumAmt = Application.WorksheetFunction.Sum(visAmt)
            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
  • ポイント:
    • 可視セルのみの集計: フィルタ後の見た目に合わせて出せる。
    • 解除忘れ防止: 最後に .AutoFilter で元に戻す。

部署ごとにシートを自動分割（行を振り分け）

Sub SplitToSheets_ByDept()
    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    Dim created As Object: Set created = CreateObject("Scripting.Dictionary")
    Dim i As Long, dept As String

    For i = 2 To UBound(v, 1)
        dept = Trim$(CStr(v(i, 1)))
        If Len(dept) = 0 Then dept = "未分類"
        If Not created.Exists(dept) Then
            created.Add dept, True
            On Error Resume Next
            Worksheets(dept).Delete '重複時の再作成対策（必要なら削除しない）
            On Error GoTo 0
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = dept
            Worksheets(dept).Range("A1").Resize(1, UBound(v, 2)).Value = rg.Rows(1).Value 'ヘッダー
        End If
        Dim rOut As Long
        rOut = Worksheets(dept).Cells(Rows.Count, 1).End(xlUp).Row + 1
        Worksheets(dept).Range("A" & rOut).Resize(1, UBound(v, 2)).Value = Application.Index(v, i, 0)
    Next
End Sub
VB
  • ポイント:
    • 部署名の空白は「未分類」へ: ラベル揺れに対応。
    • 既存シートの扱い: 既存を残したい場合はDeleteを外して、追記に切り替える。

安全・高速ラップ（大量時の基本）

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
  • ポイント:
    • 前後停止→復帰で体感速度が改善。エラー時も必ず復帰させる。

よくある落とし穴と対策

  • 部署名の表記揺れで別集計になる
    • 対策: Trim/UCase で正規化、必要なら置換表を事前適用。
  • 金額が文字列で合計されない
    • 対策: Val で数値化、可能なら元データの数値型に統一。
  • 列順変更で壊れる
    • 対策: 見出し名から列番号をFindで取得して安全に参照。
  • 部署が空欄で落ちる
    • 対策: 空欄は「未分類」キーにまとめる。
  • セル往復で遅い
    • 対策: 範囲→配列→辞書→一括書き戻しが鉄板。

例題で練習

'例1：部署リストをもとにSUMIFS/COUNTIFS/AVERAGEIFSで部署別指標
Sub Example_FunctionsDept()
    Call DeptSummary_WithFunctions
End Sub

'例2：辞書で部署別の合計・件数・平均を爆速出力
Sub Example_DictDept()
    Call DeptSummary_Dictionary
End Sub

'例3：見出し名で列を見つけて部署別集計（列順変更に強い）
Sub Example_ByHeadersDept()
    Call DeptSummary_ByHeaders
End Sub

'例4：部署ごとにシート分割して明細を振り分け
Sub Example_SplitSheets()
    Call SplitToSheets_ByDept
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました