高速集計テンプレ
「明細が数万行あるけど、部署別や月次別に一瞬で集計したい」——そんな場面で役立つのが 配列＋辞書 を使った高速集計テンプレです。セルを1行ずつ操作するのではなく、範囲を一度に配列に読み込み、メモリ上で集計してから一括で書き戻すので、初心者でも安心して使えます。
基本の考え方
- 範囲→配列:
Range("A1").CurrentRegion.Valueで表全体を配列に読み込む - 辞書で集計: キー（部署や年月）ごとに合計・件数を保持
- 一括書き戻し: 出力配列をまとめてシートに貼り付ける
これだけで「数万行でも一瞬」で集計できます。
部署別の高速集計テンプレ
Sub FastSummary_ByDept()
'明細：A=部署, B=日付, 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, dept As String, amt As Double
For i = 2 To UBound(v, 1)
dept = Trim$(CStr(v(i, 1)))
amt = Val(v(i, 3))
If sumMap.Exists(dept) Then
sumMap(dept) = sumMap(dept) + amt
cntMap(dept) = cntMap(dept) + 1
Else
sumMap.Add dept, amt
cntMap.Add dept, 1
End If
Next
'出力配列を組み立て
Dim keys As Variant: keys = sumMap.Keys
Dim n As Long: n = UBound(keys) + 1
Dim out() As Variant: 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
'シート「集計」に出力
Dim wsO As Worksheet
On Error Resume Next
Set wsO = Worksheets("集計")
If wsO Is Nothing Then Set wsO = Worksheets.Add: wsO.Name = "集計"
On Error GoTo 0
wsO.Cells.Clear
wsO.Range("A1:D1").Value = Array("部署", "合計", "件数", "平均")
wsO.Range("A2").Resize(n, 4).Value = out
wsO.Columns.AutoFit
End Sub
- ポイント
Trimで余分な空白を除去、Valで文字列を数値化。- 出力は「部署・合計・件数・平均」の4列。
月次別の高速集計テンプレ
Sub FastSummary_ByMonth()
'明細：A=日付, B=部署, 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 i As Long, ym As String, amt As Double
For i = 2 To UBound(v, 1)
ym = Format$(v(i, 1), "yyyy-mm") '年月キー
amt = Val(v(i, 3))
If sumMap.Exists(ym) Then
sumMap(ym) = sumMap(ym) + amt
Else
sumMap.Add ym, amt
End If
Next
'出力
Dim keys As Variant: keys = sumMap.Keys
Dim n As Long: n = UBound(keys) + 1
Dim out() As Variant: ReDim out(1 To n, 1 To 2)
Dim k As Long
For k = 0 To UBound(keys)
out(k + 1, 1) = keys(k)
out(k + 1, 2) = sumMap(keys(k))
Next
Dim wsO As Worksheet
On Error Resume Next
Set wsO = Worksheets("月次集計")
If wsO Is Nothing Then Set wsO = Worksheets.Add: wsO.Name = "月次集計"
On Error GoTo 0
wsO.Cells.Clear
wsO.Range("A1:B1").Value = Array("年月", "合計")
wsO.Range("A2").Resize(n, 2).Value = out
wsO.Columns.AutoFit
End Sub
- ポイント
Format$(日付,"yyyy-mm")で年月キーを作成。- 部署×年月にしたい場合はキーを
"部署|yyyy-mm"にすればOK。
高速化の基本テクニック
- セル往復を避ける: 配列に読み込んで処理、一括で書き戻す
- 画面更新・計算を止める:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'処理…
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
- 辞書でキー集計:
Scripting.Dictionaryを使うと高速で柔軟
よくある落とし穴と対策
- 日付に時刻が混じって月次集計が崩れる
→DateValueで日付に丸めるか、Format$(date,"yyyy-mm")を使う。 - 部署名の表記揺れで別集計になる
→Trim/UCaseで正規化。必要なら置換表を事前適用。 - 数値が文字列で合計されない
→Valで数値化。式は.Value = .Valueで値化。
例題で練習
'例1：部署別に合計・件数・平均を高速集計
Sub Example_Dept()
Call FastSummary_ByDept
End Sub
'例2：年月ごとに合計を高速集計
Sub Example_Month()
Call FastSummary_ByMonth
End Sub
