Excel VBA | 配列 + Dictionary を組み合わせた高速処理

VBA

2025.12.06

「アルゴリズム的な高速処理」として 頻度解析 や ランキング処理 を Excel VBA + 配列 + Dictionary で最適化する具体的なパターンを整理しました。これは大量データを扱うときに非常に強力です。

頻度解析（Frequency Analysis）
1. 目的
2. コード例
ランキング処理（Ranking）
1. 目的
2. コード例
応用アイデア
まとめ

頻度解析（Frequency Analysis）

目的

データ列の「値ごとの出現回数」を高速に集計
ピボットテーブル不要で一瞬に結果を得られる

コード例

Sub FrequencyAnalysis()
    Dim ws As Worksheet, arr As Variant, dict As Object
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    arr = ws.Range("A1:A10000").Value   ' データ列を一括読み込み
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 頻度カウント
    For i = 1 To UBound(arr, 1)
        If dict.Exists(arr(i, 1)) Then
            dict(arr(i, 1)) = dict(arr(i, 1)) + 1
        Else
            dict(arr(i, 1)) = 1
        End If
    Next
    
    ' 結果出力（値と頻度）
    ws.Range("C1").Resize(dict.Count, 1).Value = Application.Transpose(dict.Keys)
    ws.Range("D1").Resize(dict.Count, 1).Value = Application.Transpose(dict.Items)
End Sub

Sub FrequencyAnalysis()
    Dim ws As Worksheet, arr As Variant, dict As Object
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    arr = ws.Range("A1:A10000").Value   ' データ列を一括読み込み
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 頻度カウント
    For i = 1 To UBound(arr, 1)
        If dict.Exists(arr(i, 1)) Then
            dict(arr(i, 1)) = dict(arr(i, 1)) + 1
        Else
            dict(arr(i, 1)) = 1
        End If
    Next
    
    ' 結果出力（値と頻度）
    ws.Range("C1").Resize(dict.Count, 1).Value = Application.Transpose(dict.Keys)
    ws.Range("D1").Resize(dict.Count, 1).Value = Application.Transpose(dict.Items)
End Sub

👉 ポイント

配列で走査 → Dictionaryでカウント
数万行でも一瞬で集計可能

ランキング処理（Ranking）

目的

頻度やスコアを基にランキングを作成
ソートを組み合わせて順位付け

コード例

Sub RankingProcess()
    Dim ws As Worksheet, arr As Variant, dict As Object
    Dim i As Long, keys As Variant, items As Variant
    Dim tmpArr() As Variant
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    arr = ws.Range("A1:A10000").Value   ' データ列
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 頻度カウント
    For i = 1 To UBound(arr, 1)
        If dict.Exists(arr(i, 1)) Then
            dict(arr(i, 1)) = dict(arr(i, 1)) + 1
        Else
            dict(arr(i, 1)) = 1
        End If
    Next
    
    ' キーと値を配列化
    keys = dict.Keys
    items = dict.Items
    ReDim tmpArr(1 To dict.Count, 1 To 2)
    
    For i = 0 To dict.Count - 1
        tmpArr(i + 1, 1) = keys(i)
        tmpArr(i + 1, 2) = items(i)
    Next
    
    ' 頻度でソート（降順）
    Dim j As Long, k As Long, tmpKey As Variant, tmpVal As Variant
    For j = 1 To UBound(tmpArr, 1) - 1
        For k = j + 1 To UBound(tmpArr, 1)
            If tmpArr(j, 2) < tmpArr(k, 2) Then
                tmpKey = tmpArr(j, 1): tmpVal = tmpArr(j, 2)
                tmpArr(j, 1) = tmpArr(k, 1): tmpArr(j, 2) = tmpArr(k, 2)
                tmpArr(k, 1) = tmpKey: tmpArr(k, 2) = tmpVal
            End If
        Next k
    Next j
    
    ' 結果出力（ランキング）
    ws.Range("C1").Resize(UBound(tmpArr, 1), 2).Value = tmpArr
End Sub

Sub RankingProcess()
    Dim ws As Worksheet, arr As Variant, dict As Object
    Dim i As Long, keys As Variant, items As Variant
    Dim tmpArr() As Variant
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    arr = ws.Range("A1:A10000").Value   ' データ列
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 頻度カウント
    For i = 1 To UBound(arr, 1)
        If dict.Exists(arr(i, 1)) Then
            dict(arr(i, 1)) = dict(arr(i, 1)) + 1
        Else
            dict(arr(i, 1)) = 1
        End If
    Next
    
    ' キーと値を配列化
    keys = dict.Keys
    items = dict.Items
    ReDim tmpArr(1 To dict.Count, 1 To 2)
    
    For i = 0 To dict.Count - 1
        tmpArr(i + 1, 1) = keys(i)
        tmpArr(i + 1, 2) = items(i)
    Next
    
    ' 頻度でソート（降順）
    Dim j As Long, k As Long, tmpKey As Variant, tmpVal As Variant
    For j = 1 To UBound(tmpArr, 1) - 1
        For k = j + 1 To UBound(tmpArr, 1)
            If tmpArr(j, 2) < tmpArr(k, 2) Then
                tmpKey = tmpArr(j, 1): tmpVal = tmpArr(j, 2)
                tmpArr(j, 1) = tmpArr(k, 1): tmpArr(j, 2) = tmpArr(k, 2)
                tmpArr(k, 1) = tmpKey: tmpArr(k, 2) = tmpVal
            End If
        Next k
    Next j
    
    ' 結果出力（ランキング）
    ws.Range("C1").Resize(UBound(tmpArr, 1), 2).Value = tmpArr
End Sub