Excel VBA 逆引き集 | UNIQUE＋集計セット

Excel VBA
スポンサーリンク

UNIQUE＋集計セット

重複をユニーク化したあとに、合計・件数・最大/最小・最新などを一気にまとめる“鉄板テンプレ”です。ピボット不要で、辞書＋配列だけ。初心者向けに丁寧にかみ砕いて説明します。

使う場面のパターン

  • 基本集計: コードごとに数量合計・売上合計・件数。
  • 最新抽出: コードごとに最新日付の単価・ステータス。
  • 複合キー: コード×月で月次集計（件数・合計・平均）。
  • 安全出力: 元表は触らず、別シートへユニーク＋集計を出す。

共通ユーティリティ（速度・正規化）

Option Explicit

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

Private Sub SpeedOff()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v)))
End Function

Private Function NormDate(ByVal v As Variant) As Date
    If IsDate(v) Then NormDate = CDate(v) Else NormDate = 0
End Function

Private Function EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = name
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function
VB
  • ポイント
    • 速度最適化: 画面更新・イベント・計算を止める。
    • キー正規化: Trim＋大文字化で表記揺れ対策。
    • 日付変換: NormDateで安全にDateへ。

基本テンプレ：コードごとにUNIQUE＋集計（合計・件数・最新）

入力「Data」シート例（見出しあり）：A=コード、B=日付、C=数量、D=単価。
出力「集計」シート：コードごとに数量合計、売上合計、件数、最新日付の単価。

Sub UniqueAggregate_Basic()
    SpeedOn

    Dim ws As Worksheet: Set ws = Worksheets("Data")
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value

    '列インデックス（必要ならFindで見出し検索に変更可能）
    Dim cCode As Long: cCode = 1
    Dim cDate As Long: cDate = 2
    Dim cQty  As Long: cQty  = 3
    Dim cPrice As Long: cPrice = 4

    'グループ辞書
    Dim sumQty As Object: Set sumQty = CreateObject("Scripting.Dictionary")
    Dim sumSales As Object: Set sumSales = CreateObject("Scripting.Dictionary")
    Dim cnt As Object: Set cnt = CreateObject("Scripting.Dictionary")
    Dim latestDate As Object: Set latestDate = CreateObject("Scripting.Dictionary")
    Dim latestPrice As Object: Set latestPrice = CreateObject("Scripting.Dictionary")

    Dim r As Long, k As String, d As Date
    For r = 2 To UBound(v, 1)
        k = NormKey(v(r, cCode))
        If Len(k) = 0 Then GoTo cont
        d = NormDate(v(r, cDate))

        '集計（初期値は0扱い）
        sumQty(k) = CDbl(Val(sumQty(k))) + CDbl(Val(v(r, cQty)))
        sumSales(k) = CDbl(Val(sumSales(k))) + CDbl(Val(v(r, cQty))) * CDbl(Val(v(r, cPrice)))
        cnt(k) = CLng(Val(cnt(k))) + 1

        '最新日付の単価を保持
        If d > 0 Then
            If Not latestDate.Exists(k) Or d > latestDate(k) Then
                latestDate(k) = d
                latestPrice(k) = CDbl(Val(v(r, cPrice)))
            End If
        End If
cont:
    Next

    '出力
    Dim out As Worksheet: Set out = EnsureSheet("集計", True)
    out.Range("A1:F1").Value = Array("コード", "数量合計", "売上合計", "件数", "最新日付", "最新単価")

    Dim i As Long: i = 2
    Dim key As Variant
    For Each key In sumQty.Keys
        out.Cells(i, 1).Value = key
        out.Cells(i, 2).Value = sumQty(key)
        out.Cells(i, 3).Value = sumSales(key)
        out.Cells(i, 4).Value = cnt(key)
        If latestDate.Exists(key) Then
            out.Cells(i, 5).Value = latestDate(key)
            out.Cells(i, 5).NumberFormatLocal = "yyyy/mm/dd"
            out.Cells(i, 6).Value = latestPrice(key)
        End If
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "UNIQUE＋集計（基本）完了: " & i - 2 & "コード"
End Sub
VB
  • ポイント
    • UNIQUE化は辞書のKeysが自然に担います。
    • 売上合計: 数量×単価を積み上げ。
    • 最新: 日付比較で最大の日の単価採用。

複合キー：コード×月でUNIQUE＋月次集計（件数・合計・平均）

A=コード、B=日付、C=数量、D=金額（数量×単価でもOK）。
出力は「コード×yyyy-mm」のユニークキーで件数、合計数量、合計金額、平均単価（合計金額/合計数量）。

Sub UniqueAggregate_MonthlyComposite()
    SpeedOn

    Dim v As Variant: v = Worksheets("Data").Range("A1").CurrentRegion.Value
    Dim cCode As Long: cCode = 1
    Dim cDate As Long: cDate = 2
    Dim cQty  As Long: cQty  = 3
    Dim cAmt  As Long: cAmt  = 4

    '複合キー辞書（code|yyyy-mm）
    Dim sumQty As Object: Set sumQty = CreateObject("Scripting.Dictionary")
    Dim sumAmt As Object: Set sumAmt = CreateObject("Scripting.Dictionary")
    Dim cnt As Object: Set cnt = CreateObject("Scripting.Dictionary")

    Dim r As Long, code As String, d As Date, ym As String, key As String
    For r = 2 To UBound(v, 1)
        code = NormKey(v(r, cCode))
        d = NormDate(v(r, cDate))
        If Len(code) = 0 Or d = 0 Then GoTo cont
        ym = Format$(d, "yyyy-mm")
        key = code & "|" & ym

        sumQty(key) = CDbl(Val(sumQty(key))) + CDbl(Val(v(r, cQty)))
        sumAmt(key) = CDbl(Val(sumAmt(key))) + CDbl(Val(v(r, cAmt)))
        cnt(key) = CLng(Val(cnt(key))) + 1
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("月次集計", True)
    out.Range("A1:F1").Value = Array("コード", "年月", "件数", "数量合計", "金額合計", "平均単価")

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In sumQty.Keys
        Dim parts() As String: parts = Split(CStr(k), "|")
        out.Cells(i, 1).Value = parts(0)
        out.Cells(i, 2).Value = parts(1)
        out.Cells(i, 3).Value = cnt(k)
        out.Cells(i, 4).Value = sumQty(k)
        out.Cells(i, 5).Value = sumAmt(k)
        If sumQty(k) <> 0 Then out.Cells(i, 6).Value = sumAmt(k) / sumQty(k)
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "UNIQUE＋月次集計完了: " & i - 2 & "グループ"
End Sub
VB
  • ポイント
    • 複合キー: 区切りに「|」を使うと安全。
    • 平均単価: 金額合計/数量合計。

高速カスタム集計：合計・最大・最小・最新を一度に

要件が増えても一度に処理する“拡張セット”。A=コード、B=日付、C=数量、D=単価。

Sub UniqueAggregate_AdvancedSet()
    SpeedOn

    Dim v As Variant: v = Worksheets("Data").Range("A1").CurrentRegion.Value
    Dim cCode As Long: cCode = 1
    Dim cDate As Long: cDate = 2
    Dim cQty  As Long: cQty  = 3
    Dim cPrice As Long: cPrice = 4

    Dim sumQty As Object: Set sumQty = CreateObject("Scripting.Dictionary")
    Dim maxPrice As Object: Set maxPrice = CreateObject("Scripting.Dictionary")
    Dim minPrice As Object: Set minPrice = CreateObject("Scripting.Dictionary")
    Dim latestDate As Object: Set latestDate = CreateObject("Scripting.Dictionary")
    Dim latestPrice As Object: Set latestPrice = CreateObject("Scripting.Dictionary")
    Dim cnt As Object: Set cnt = CreateObject("Scripting.Dictionary")

    Dim r As Long, k As String, d As Date, q As Double, p As Double
    For r = 2 To UBound(v, 1)
        k = NormKey(v(r, cCode))
        If Len(k) = 0 Then GoTo cont
        d = NormDate(v(r, cDate))
        q = CDbl(Val(v(r, cQty)))
        p = CDbl(Val(v(r, cPrice)))

        sumQty(k) = CDbl(Val(sumQty(k))) + q
        cnt(k) = CLng(Val(cnt(k))) + 1

        If Not maxPrice.Exists(k) Or p > maxPrice(k) Then maxPrice(k) = p
        If Not minPrice.Exists(k) Or p < minPrice(k) Then minPrice(k) = p

        If d > 0 Then
            If Not latestDate.Exists(k) Or d > latestDate(k) Then
                latestDate(k) = d
                latestPrice(k) = p
            End If
        End If
cont:
    Next

    Dim out As Worksheet: Set out = EnsureSheet("拡張集計", True)
    out.Range("A1:G1").Value = Array("コード", "件数", "数量合計", "最大単価", "最小単価", "最新日付", "最新単価")

    Dim i As Long: i = 2
    Dim key As Variant
    For Each key In cnt.Keys
        out.Cells(i, 1).Value = key
        out.Cells(i, 2).Value = cnt(key)
        out.Cells(i, 3).Value = sumQty(key)
        out.Cells(i, 4).Value = maxPrice(key)
        out.Cells(i, 5).Value = minPrice(key)
        If latestDate.Exists(key) Then
            out.Cells(i, 6).Value = latestDate(key)
            out.Cells(i, 6).NumberFormatLocal = "yyyy/mm/dd"
            out.Cells(i, 7).Value = latestPrice(key)
        End If
        i = i + 1
    Next

    out.Columns.AutoFit
    SpeedOff
    MsgBox "UNIQUE＋拡張集計完了: " & i - 2 & "コード"
End Sub
VB
  • ポイント
    • 一括集計: 計算をループ内で全て済ませるので速い。
    • 初期値管理: Existsで初回代入→以降更新。

例題と運用のコツ

  • 例題1（基本集計）: コードごとに数量合計・売上合計・最新単価
    • 実行: UniqueAggregate_Basic
  • 例題2（月次集計）: コード×月の件数・合計・平均単価
    • 実行: UniqueAggregate_MonthlyComposite
  • 例題3（拡張セット）: 合計・最大/最小・最新の一括出力
    • 実行: UniqueAggregate_AdvancedSet
  • コツ
    • キーの正規化は必須: 前後空白・大小文字で別物扱いを防ぐ。
    • 日付統一: CDateでDate型にしてからFormatは出力で行う。
    • 元表を触らない: 常に別シートへ出力すると安全。
    • 列特定を堅く: 実務では見出し名から列番号を取得（Find）に置き換えると壊れない。
スポンサーリンク
タイトルとURLをコピーしました