Excel VBA 逆引き集 | 辞書を使った高速ループ

Excel VBA
スポンサーリンク

辞書を使った高速ループ

大量データの「検索・集計・重複排除」を高速化する最短手段が Scripting.Dictionary（連想配列）です。キーで即アクセスできるので、セルを何度も探しに行く処理を置き換えると劇的に速くなります。初心者向けに、準備から定番パターンまでをまとめました。

辞書の基本と準備

'遅延バインディング（参照設定不要・汎用）
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

'早期バインディング（Microsoft Scripting Runtime に参照設定）
'Dim dict As Scripting.Dictionary
'Set dict = New Scripting.Dictionary
VB
  • キモ:
    • キー重複なし: 同じキーは1件のみ。辞書は「検索が速い」構造。
    • 主な操作: Add（追加）、Item（取得・更新）、Exists（キー有無）、Remove（削除）、Keys/Items（一覧）。
    • 用途の軸: 「該当レコードを素早く見つける」「キー別に合計・最小最大・件数」など。

定番１：重複排除（ユニークリストの作成）

Sub Deduplicate_ToAnotherSheet()
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim last As Long, r As Long
    last = Cells(Rows.Count, "A").End(xlUp).Row

    For r = 2 To last
        dict(Cells(r, "A").Value) = True  '存在フラグだけ入れる
    Next

    Dim i As Long
    For i = 0 To dict.Count - 1
        Worksheets("Unique").Cells(i + 1, "A").Value = dict.Keys()(i)
    Next
End Sub
VB
  • ポイント:
    • 存在フラグ: 値は True など何でもOK。キー一覧だけ欲しいならこれで十分。
    • 出力: keys を並べるだけでユニークリストが完成。

定番２：キー別に合計・件数（グループ集計）

Sub GroupSum_Count()
    Dim dictSum As Object: Set dictSum = CreateObject("Scripting.Dictionary")
    Dim dictCnt As Object: Set dictCnt = CreateObject("Scripting.Dictionary")

    Dim last As Long, r As Long, k As Variant, v As Double
    last = Cells(Rows.Count, "A").End(xlUp).Row

    For r = 2 To last
        k = Cells(r, "B").Value          '例：部門キー
        v = Val(Cells(r, "E").Value)     '例：金額
        If Not dictSum.Exists(k) Then
            dictSum.Add k, v
            dictCnt.Add k, 1
        Else
            dictSum(k) = dictSum(k) + v
            dictCnt(k) = dictCnt(k) + 1
        End If
    Next

    Dim i As Long
    For i = 0 To dictSum.Count - 1
        Cells(i + 2, "H").Value = dictSum.Keys()(i)  '部門
        Cells(i + 2, "I").Value = dictSum.Items()(i) '合計
        Cells(i + 2, "J").Value = dictCnt(dictSum.Keys()(i)) '件数
    Next
End Sub
VB
  • ポイント:
    • Exists で初期化 or 更新: 初回は Add、以降は加算。
    • 同一キーの集約: ピボット前の前処理・軽量レポートに使える。

定番３：爆速ルックアップ（VLOOKUPの代替）

Sub FastLookup_ReplaceVlookup()
    '参照表（コード→単価）を辞書化
    Dim price As Object: Set price = CreateObject("Scripting.Dictionary")
    Dim lastRef As Long, r As Long
    lastRef = Worksheets("Ref").Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To lastRef
        price(Worksheets("Ref").Cells(r, "A").Value) = Worksheets("Ref").Cells(r, "B").Value
    Next

    '明細側でルックアップして合計金額を出す
    Dim last As Long: last = Cells(Rows.Count, "C").End(xlUp).Row
    For r = 2 To last
        Dim code As Variant, qty As Double
        code = Cells(r, "C").Value
        qty = Val(Cells(r, "D").Value)
        If price.Exists(code) Then
            Cells(r, "E").Value = qty * price(code)
        Else
            Cells(r, "E").Value = ""  '未定義コード
        End If
    Next
End Sub
VB
  • ポイント:
    • O(1) 検索: ルックアップが配列やセル探索より桁違いに速い。
    • 未登録キー: Exists で安全に分岐。

定番４：二重キー（複合キー）でグループ化

Sub GroupBy_TwoKeys()
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim last As Long, r As Long
    last = Cells(Rows.Count, "A").End(xlUp).Row

    Dim dep As String, ym As String, k As String, amt As Double
    For r = 2 To last
        dep = Cells(r, "B").Value        '部門
        ym  = Format(Cells(r, "D").Value, "yyyy-mm")  '年月
        k   = dep & "|" & ym             '複合キー
        amt = Val(Cells(r, "E").Value)
        If Not dict.Exists(k) Then
            dict.Add k, amt
        Else
            dict(k) = dict(k) + amt
        End If
    Next

    Dim i As Long
    For i = 0 To dict.Count - 1
        Dim parts() As String
        parts = Split(dict.Keys()(i), "|")
        Cells(i + 2, "H").Value = parts(0)      '部門
        Cells(i + 2, "I").Value = parts(1)      '年月
        Cells(i + 2, "J").Value = dict.Items()(i) '合計
    Next
End Sub
VB
  • ポイント:
    • 複合キー: 区切り文字で連結して一意化。Split で分解して出力。

定番５：配列×辞書で超高速（読み込み→集計→一括書き戻し）

Sub ArrayAndDict_Fast()
    Dim rg As Range: Set rg = Range("A2:E200000") '大量データ想定
    Dim data As Variant: data = rg.Value          '2次元配列へ

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim r As Long, k As Variant, v As Double

    For r = 1 To UBound(data, 1)
        k = data(r, 2)           'B列キー
        v = Val(data(r, 5))      'E列金額
        If Not dict.Exists(k) Then
            dict.Add k, v
        Else
            dict(k) = dict(k) + v
        End If
    Next

    '結果の書き出し（行数=辞書件数）
    Dim outRows As Long: outRows = dict.Count
    Dim out() As Variant: ReDim out(1 To outRows, 1 To 2)
    Dim i As Long
    For i = 0 To dict.Count - 1
        out(i + 1, 1) = dict.Keys()(i)
        out(i + 1, 2) = dict.Items()(i)
    Next
    Range("H2").Resize(outRows, 2).Value = out
End Sub
VB
  • ポイント:
    • 配列で読み込む: セルに毎回触らず、辞書と配列で完結させるのが最速。
    • 一括書き戻し: まとめて Range.Value に渡す。

例題で練習

'例題1：顧客コードの重複行を最初の1件だけ残して削除
Sub Example_RemoveDuplicateRows()
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim last As Long, r As Long
    last = Cells(Rows.Count, "A").End(xlUp).Row

    For r = last To 2 Step -1
        Dim k As Variant: k = Cells(r, "A").Value
        If dict.Exists(k) Then
            Rows(r).Delete
        Else
            dict.Add k, True
        End If
    Next
End Sub

'例題2：商品別に数量と金額を同時集計（複合アイテム）
Sub Example_SumQtyAmount()
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim last As Long, r As Long, k As Variant
    last = Cells(Rows.Count, "B").End(xlUp).Row
    For r = 2 To last
        k = Cells(r, "B").Value '商品コード
        If Not dict.Exists(k) Then dict.Add k, Array(0#, 0#) '数量, 金額
        Dim qty As Double, amt As Double
        qty = Val(Cells(r, "C").Value)
        amt = Val(Cells(r, "E").Value)
        Dim a As Variant: a = dict(k)
        a(0) = a(0) + qty
        a(1) = a(1) + amt
        dict(k) = a
    Next
    '出力
    Dim i As Long
    For i = 0 To dict.Count - 1
        Cells(i + 2, "H").Value = dict.Keys()(i)
        Cells(i + 2, "I").Value = dict.Items()(i)(0)
        Cells(i + 2, "J").Value = dict.Items()(i)(1)
    Next
End Sub

'例題3：別シートの名称引き当てを辞書化して一気に付与
Sub Example_FillNameByCode()
    Dim nameMap As Object: Set nameMap = CreateObject("Scripting.Dictionary")
    Dim lr As Long, r As Long
    lr = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To lr
        nameMap(Worksheets("Master").Cells(r, "A").Value) = _
               Worksheets("Master").Cells(r, "B").Value
    Next

    Dim last As Long: last = Cells(Rows.Count, "C").End(xlUp).Row
    For r = 2 To last
        Dim code As Variant: code = Cells(r, "C").Value
        If nameMap.Exists(code) Then Cells(r, "D").Value = nameMap(code)
    Next
End Sub
VB

実務の落とし穴と対策

  • キーの型混在:
    • 注意: “123”（文字列）と 123（数値）は別キー。入力元の型を揃えるか、CStr/CLng で統一。
  • メモリ肥大:
    • 大量格納: 巨大データでは辞書が大きくなる。必要最小限の項目だけ持たせ、途中で RemoveAll を活用。
  • 順序を保持しない:
    • 並び替えが必要なら: 出力時に配列へ落として並べ替え、または Keys をソートしてから書き出す。
  • 速度最適化:
    • 基本: 配列で読み込み→辞書で集計→配列で出力。ScreenUpdating/Calculation をオフで包む。
  • 早期/遅延バインディング:
    • 早期: コード補完が効いて書きやすい。参照設定が必要。
    • 遅延: 参照設定不要で配布が楽。CreateObject("Scripting.Dictionary") を使用。
Sub SpeedWrap_Dict()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    '…辞書×配列の本処理…

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました