Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – 集計テンプレ

Excel VBA
スポンサーリンク
  1. ねらい：配列I/O＋Dictionaryで「速く・壊れない」集計を標準化する
  2. 基盤部品：配列I/O・キー正規化・ヘッダ扱い
    1. 配列I/Oとキー生成
    2. 重要ポイントの深掘り
  3. 単一キーの基本集計：合計・件数・平均
    1. 顧客IDごとの合計・件数・平均を出力する
    2. 重要ポイントの深掘り
  4. 複合キー・複数メジャー：カテゴリ×月の合計・件数など
    1. 複合キーで集計し、複数の数値列を同時にまとめる
    2. 重要ポイントの深掘り
  5. ピボット風：行＝キー、列＝月のクロス集計
    1. 行列マップを作ってクロス表へ展開する
    2. 重要ポイントの深掘り
  6. ランキング・上位抽出：集計後に順位を付ける
    1. 合計で降順に並べて上位Nを抽出する
    2. 重要ポイントの深掘り
  7. パーセンタイル・分位集計：しきい値分類や等分割
    1. しきい値で区分を付ける（次小マッチ）
    2. 重要ポイントの深掘り
  8. 日付集計・週次集計：日付から期間キーを作る
    1. 日付→月キーで合計、週番号で合計
    2. 重要ポイントの深掘り
  9. 例題の通し方：顧客別・月別の売上合計と上位10社
    1. 実行例
    2. 期待動作の確認ポイント
  10. 落とし穴と対策（深掘り）
    1. 正規化不足でグループが割れる
    2. 文字数値が混入して平均・並べ替えが壊れる
    3. セル逐次書きで遅く・固まる
    4. ソート・近似一致の未ソート前提違反
  11. まとめ：集計は「配列中心・辞書グループ化・正規化」で速くて頑固に

ねらい：配列I/O＋Dictionaryで「速く・壊れない」集計を標準化する

集計は「グループ化→集計→並べ替え→出力」の型にすれば、10万行級でも安定して一瞬で終わります。Excel関数の複雑な組み合わせやピボットの手作業を、VBAの“再利用部品”に置き換えます。初心者でも貼って動くテンプレを、合計・件数・平均・複合キー・複数メジャー・日付集計・ランキング・パーセンタイルまでかみ砕いて説明します。

基盤部品：配列I/O・キー正規化・ヘッダ扱い

配列I/Oとキー生成

' ModAgg_Base.bas
Option Explicit
Private Const SEP As String = Chr$(30) ' 複合キーの安全な区切り

Public Function ReadRegion(ByVal ws As Worksheet, Optional ByVal topLeft As String = "A1") As Variant
    ReadRegion = ws.Range(topLeft).CurrentRegion.Value
End Function

Public Sub WriteBlock(ByVal ws As Worksheet, ByVal a As Variant, ByVal topLeft As String)
    ws.Range(topLeft).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

Public Function NormKey(ByVal v As Variant) As String
    NormKey = LCase$(Trim$(CStr(v)))
End Function

Public Function MakeKey2(ByVal v1 As Variant, ByVal v2 As Variant) As String
    MakeKey2 = NormKey(v1) & SEP & NormKey(v2)
End Function
VB

重要ポイントの深掘り

  • ヘッダは1行目固定、データは2行目から扱うと事故が激減します。
  • キーは必ず正規化（Trim/LCase）して揺らぎを消します。複合キーは“ありえない文字”で束ね、誤結合を防ぎます。
  • 集計は“配列中心”で完結し、最後に一括書き戻すと桁違いに速くなります。

単一キーの基本集計：合計・件数・平均

顧客IDごとの合計・件数・平均を出力する

' ModAgg_Simple.bas
Option Explicit

' srcSheet: 入力（A=キー、B=数値列）
' outStart: 出力開始セル（例 "Z1"）
Public Sub GroupSumCountAvg(ByVal srcSheet As String, ByVal outStart As String)
    Dim a As Variant: a = ReadRegion(Worksheets(srcSheet))

    Dim sumD As Object: Set sumD = CreateObject("Scripting.Dictionary"): sumD.CompareMode = 1
    Dim cntD As Object: Set cntD = CreateObject("Scripting.Dictionary"): cntD.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim k As String: k = NormKey(a(r, 1))
        Dim v As Double: v = Val(CStr(a(r, 2)))
        If sumD.Exists(k) Then
            sumD(k) = sumD(k) + v: cntD(k) = cntD(k) + 1
        Else
            sumD(k) = v: cntD(k) = 1
        End If
    Next

    ' 出力配列（Key, Sum, Count, Avg）
    Dim out() As Variant: ReDim out(1 To sumD.Count + 1, 1 To 4)
    out(1, 1) = a(1, 1): out(1, 2) = "Sum": out(1, 3) = "Count": out(1, 4) = "Avg"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In sumD.Keys
        out(i, 1) = k
        out(i, 2) = sumD(k)
        out(i, 3) = cntD(k)
        out(i, 4) = IIf(cntD(k) > 0, sumD(k) / cntD(k), 0)
        i = i + 1
    Next

    WriteBlock Worksheets(srcSheet), out, outStart
End Sub
VB

重要ポイントの深掘り

  • 数値は Val/Cdbl で必ず数値化（文字数値のままだと平均や並べ替えで破綻します）。
  • 件数と合計を同時に持つと平均は後から自由に算出できます（端数処理は要件に合わせて）。

複合キー・複数メジャー：カテゴリ×月の合計・件数など

複合キーで集計し、複数の数値列を同時にまとめる

' ModAgg_CompositeMulti.bas
Option Explicit

' 入力：A=カテゴリ, B=月, C=金額, D=数量
' 出力：Key(カテゴリ|月), SumAmount, SumQty, Count
Public Sub GroupByCatMonth_Sums(ByVal srcSheet As String, ByVal outStart As String)
    Dim a As Variant: a = ReadRegion(Worksheets(srcSheet))
    Dim sumAmt As Object: Set sumAmt = CreateObject("Scripting.Dictionary"): sumAmt.CompareMode = 1
    Dim sumQty As Object: Set sumQty = CreateObject("Scripting.Dictionary"): sumQty.CompareMode = 1
    Dim cntD As Object: Set cntD = CreateObject("Scripting.Dictionary"): cntD.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim key As String: key = MakeKey2(a(r, 1), a(r, 2))
        Dim amt As Double: amt = Val(CStr(a(r, 3)))
        Dim qty As Double: qty = Val(CStr(a(r, 4)))
        If sumAmt.Exists(key) Then
            sumAmt(key) = sumAmt(key) + amt
            sumQty(key) = sumQty(key) + qty
            cntD(key) = cntD(key) + 1
        Else
            sumAmt(key) = amt
            sumQty(key) = qty
            cntD(key) = 1
        End If
    Next

    Dim out() As Variant: ReDim out(1 To sumAmt.Count + 1, 1 To 4)
    out(1, 1) = "Category|Month": out(1, 2) = "SumAmount"
    out(1, 3) = "SumQty": out(1, 4) = "Count"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In sumAmt.Keys
        out(i, 1) = k
        out(i, 2) = sumAmt(k)
        out(i, 3) = sumQty(k)
        out(i, 4) = cntD(k)
        i = i + 1
    Next

    WriteBlock Worksheets(srcSheet), out, outStart
End Sub
VB

重要ポイントの深掘り

  • 複数のメジャー（金額・数量）を同時に辞書で集計すると、走査は1回で済み高速です。
  • キー表示は“人が読める形”にまとめる（例：カテゴリ|月）。列展開は後段で可能です。

ピボット風：行＝キー、列＝月のクロス集計

行列マップを作ってクロス表へ展開する

' ModAgg_PivotLike.bas
Option Explicit

' 入力：A=カテゴリ, B=月, C=金額
' 出力：行=カテゴリ、列=各月の合計（金額）
Public Sub PivotSum(ByVal srcSheet As String, ByVal outStart As String)
    Dim a As Variant: a = ReadRegion(Worksheets(srcSheet))

    ' ユニークカテゴリ・ユニーク月を収集
    Dim cats As Object: Set cats = CreateObject("Scripting.Dictionary"): cats.CompareMode = 1
    Dim months As Object: Set months = CreateObject("Scripting.Dictionary"): months.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        cats(NormKey(a(r, 1))) = True
        months(NormKey(a(r, 2))) = True
    Next

    ' カテゴリ×月 → 合計の辞書
    Dim map As Object: Set map = CreateObject("Scripting.Dictionary"): map.CompareMode = 1
    For r = 2 To UBound(a, 1)
        Dim k As String: k = MakeKey2(a(r, 1), a(r, 2))
        Dim v As Double: v = Val(CStr(a(r, 3)))
        map(k) = IIf(map.Exists(k), map(k) + v, v)
    Next

    ' 出力配列（ヘッダ；カテゴリ＋各月）
    Dim out() As Variant: ReDim out(1 To cats.Count + 1, 1 To months.Count + 1)
    out(1, 1) = "Category"
    Dim mKeys() As Variant: mKeys = months.Keys
    Dim c As Long
    For c = 0 To UBound(mKeys)
        out(1, c + 2) = mKeys(c)
    Next

    ' 各行（カテゴリごと）
    Dim i As Long: i = 2
    Dim catKeys() As Variant: catKeys = cats.Keys
    Dim j As Long
    For j = 0 To UBound(catKeys)
        Dim cat As String: cat = catKeys(j)
        out(i, 1) = cat
        For c = 0 To UBound(mKeys)
            Dim k As String: k = MakeKey2(cat, mKeys(c))
            out(i, c + 2) = IIf(map.Exists(k), map(k), 0)
        Next
        i = i + 1
    Next

    WriteBlock Worksheets(srcSheet), out, outStart
End Sub
VB

重要ポイントの深掘り

  • 行と列のユニークを先に取り、キー×キーで辞書を引くとクロス集計が安定します。
  • 欠損セルはゼロで埋めるなど、下流の合算やグラフの仕様に合わせて統一します。

ランキング・上位抽出：集計後に順位を付ける

合計で降順に並べて上位Nを抽出する

' ModAgg_Rank.bas
Option Explicit

' 入力：A=キー, B=数値
' 出力：Sum降順の上位N
Public Sub TopN(ByVal srcSheet As String, ByVal outStart As String, ByVal topN As Long)
    Dim a As Variant: a = ReadRegion(Worksheets(srcSheet))

    Dim sumD As Object: Set sumD = CreateObject("Scripting.Dictionary"): sumD.CompareMode = 1
    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim k As String: k = NormKey(a(r, 1))
        Dim v As Double: v = Val(CStr(a(r, 2)))
        sumD(k) = IIf(sumD.Exists(k), sumD(k) + v, v)
    Next

    ' 辞書→配列化（Key, Sum）
    Dim rows As Long: rows = sumD.Count
    Dim t() As Variant: ReDim t(1 To rows, 1 To 2)
    Dim i As Long: i = 1
    Dim k As Variant
    For Each k In sumD.Keys
        t(i, 1) = k: t(i, 2) = sumD(k): i = i + 1
    Next

    ' 降順ソート（Sum）
    Call Sort2DByColDesc(t, 2)

    ' 出力（ヘッダ＋上位N）
    Dim out() As Variant: ReDim out(1 To WorksheetFunction.Min(topN + 1, rows + 1), 1 To 2)
    out(1, 1) = a(1, 1): out(1, 2) = "Sum"
    For i = 2 To UBound(out, 1)
        out(i, 1) = t(i - 1, 1)
        out(i, 2) = t(i - 1, 2)
    Next
    WriteBlock Worksheets(srcSheet), out, outStart
End Sub

Private Sub Sort2DByColDesc(ByRef a As Variant, ByVal col As Long)
    Dim n As Long: n = UBound(a, 1)
    Dim i As Long, j As Long
    For i = 1 To n - 1
        For j = i + 1 To n
            If CDbl(a(i, col)) < CDbl(a(j, col)) Then
                Dim k As Long
                For k = 1 To UBound(a, 2)
                    Dim tmp As Variant: tmp = a(i, k)
                    a(i, k) = a(j, k)
                    a(j, k) = tmp
                Next
            End If
        Next
    Next
End Sub
VB

重要ポイントの深掘り

  • ソート前に“数値化”が必須。文字数値のままでは降順が崩れます。
  • 高速な安定ソートに差し替える余地あり（大規模ならマージソート推奨）。

パーセンタイル・分位集計：しきい値分類や等分割

しきい値で区分を付ける（次小マッチ）

' ModAgg_Threshold.bas
Option Explicit

' 入力：Scores A=ID, B=点数
' マスタ：RankMaster A=しきい値（昇順）, B=区分名
' 出力：IDごとに区分
Public Sub LabelByThreshold(ByVal scoresSheet As String, ByVal masterSheet As String, ByVal outStart As String)
    Dim s As Variant: s = ReadRegion(Worksheets(scoresSheet))
    Dim m As Variant: m = ReadRegion(Worksheets(masterSheet))

    ' 二分探索用（昇順前提）
    Dim out() As Variant: ReDim out(1 To UBound(s, 1), 1 To 2)
    out(1, 1) = s(1, 1): out(1, 2) = "Bucket"

    Dim r As Long
    For r = 2 To UBound(s, 1)
        Dim score As Double: score = Val(CStr(s(r, 2)))
        Dim idx As Long: idx = BinSearchNextSmaller(m, score)
        out(r, 1) = s(r, 1)
        out(r, 2) = IIf(idx > 0, m(idx, 2), "")
    Next
    WriteBlock Worksheets(scoresSheet), out, outStart
End Sub

Private Function BinSearchNextSmaller(ByVal aM As Variant, ByVal key As Double) As Long
    Dim lo As Long: lo = 2, hi As Long: hi = UBound(aM, 1), mid As Long
    Do While lo <= hi
        mid = (lo + hi) \ 2
        Dim v As Double: v = Val(CStr(aM(mid, 1)))
        If v = key Then BinSearchNextSmaller = mid: Exit Function
        If v < key Then lo = mid + 1 Else hi = mid - 1
    Loop
    BinSearchNextSmaller = IIf(hi >= 2, hi, 0)
End Function
VB

重要ポイントの深掘り

  • 近似一致は“ソート前提”。しきい値テーブルを昇順に保つ運用ルールが必須です。
  • 分位（四分位・十分位）も同様のアプローチで実装可能です。

日付集計・週次集計：日付から期間キーを作る

日付→月キーで合計、週番号で合計

' ModAgg_Date.bas
Option Explicit

Public Sub MonthlySum(ByVal srcSheet As String, ByVal outStart As String)
    Dim a As Variant: a = ReadRegion(Worksheets(srcSheet))
    Dim sumD As Object: Set sumD = CreateObject("Scripting.Dictionary"): sumD.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim dt As Date: dt = CDate(a(r, 1)) ' A=日付
        Dim monKey As String: monKey = Format(dt, "yyyy-mm")
        Dim v As Double: v = Val(CStr(a(r, 2))) ' B=金額
        sumD(monKey) = IIf(sumD.Exists(monKey), sumD(monKey) + v, v)
    Next

    Dim out() As Variant: ReDim out(1 To sumD.Count + 1, 1 To 2)
    out(1, 1) = "Month": out(1, 2) = "Sum"
    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In sumD.Keys
        out(i, 1) = k: out(i, 2) = sumD(k): i = i + 1
    Next
    WriteBlock Worksheets(srcSheet), out, outStart
End Sub
VB

重要ポイントの深掘り

  • 期間キー（yyyy-mm、週番号）を先に作ると、集計が単純になり安定します。
  • 週番号は業務定義に揺らぎがあるため、仕様（週の開始曜日）を先に決めます。

例題の通し方：顧客別・月別の売上合計と上位10社

実行例

' ModAgg_Example.bas
Option Explicit

Public Sub Demo_Agg()
    ' 顧客別合計・件数・平均
    GroupSumCountAvg "Detail", "Z1"
    ' カテゴリ×月の複合集計
    GroupByCatMonth_Sums "Detail", "AA1"
    ' 月次合計
    MonthlySum "Detail", "AC1"
    ' 上位10社
    TopN "Detail", "AE1", 10
    MsgBox "集計テンプレの実行が完了しました。", vbInformation
End Sub
VB

期待動作の確認ポイント

  • すべての集計がヘッダ付きで出力され、欠損や文字数値が混じっていても壊れずに計算されます。
  • 数万〜十万行でも一瞬。セル関数より格段に速いはずです。

落とし穴と対策（深掘り）

正規化不足でグループが割れる

キーは必ず NormKey（Trim/LCase）。必要なら全半角統一や余計な記号除去の前処理を追加。

文字数値が混入して平均・並べ替えが壊れる

Val/CDblで明示的に数値化。非数値は0扱いなど、運用ポリシーを最初に決める。

セル逐次書きで遅く・固まる

配列で結果を作り、一括書き戻す。ヘッダは1行目固定、データは2行目から。

ソート・近似一致の未ソート前提違反

二分探索やしきい値判定は昇順が前提。前処理で安定ソートするか、ソートされた表を保つ運用に。

まとめ：集計は「配列中心・辞書グループ化・正規化」で速くて頑固に

  • 合計・件数・平均は辞書で一発、複合キー・複数メジャーも同じ枠組みで拡張。
  • ピボット風のクロス集計やランキング、期間集計、しきい値分類まで“同じ型”で回せます。
  • 正規化と数値化、ヘッダ固定、一括書き戻しの基本を守れば、規模が大きくても壊れません。

スポンサーリンク
タイトルとURLをコピーしました