VBA Dictionary (COUNTIFのように集計)

2025.11.26

項目ごとに集計(カウント)

セル直接版

Sub CountFruitsWithDictionary()
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim ws As Worksheet    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim lastRow As Long
    With ws
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).row
    End With
    Dim i As Long
    Dim fruit As String
    
    For i = 1 To lastRow
        '該当するセル値を前後の空白除去して代入
        fruit = Trim(ws.Cells(i, 1).Value)
        '文字列が０以上の場合
        If Len(fruit) > 0 Then
            'Dictionaryにfruitというラベルが存在する場合
            If dict.Exists(fruit) Then
                '該当ラベルの値を１加算して上書き
                dict(fruit) = dict(fruit) + 1
            'Dictionaryにfruitというラベルがない場合
            Else
                'ラベルを追加、値は1（初回）
                dict.Add fruit, 1
            End If
        End If
    Next i

    ' 結果をB列に出力
    Dim key As Variant
    Dim row As Long
    row = 1
    'Dictionary内をループ処理
    For Each key In dict.Keys
        'B列にラベル名を表示
        ws.Cells(row, 2).Value = key
        'C列にラベルの値を表示
        ws.Cells(row, 3).Value = dict(key)
        '行のカウントアップ
        row = row + 1
    Next key

    MsgBox "カウント完了！", vbInformation
End Sub

→

配列利用版

'配列版
Sub CountFruitsWithDictionary2()

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim ws As Worksheet
    Dim data As Variant
    Dim i As Long, lastRow As Long
    Dim fruit As String
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' A列の最終行取得 → 1列の2次元配列
    With ws
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
        data = .Range("A1:A" & lastRow).Value
    End With

    ' 集計処理
    For i = 1 To UBound(data, 1)
        fruit = Trim(data(i, 1))
        If Len(fruit) > 0 Then
            If dict.Exists(fruit) Then
                dict(fruit) = dict(fruit) + 1
            Else
                dict.Add fruit, 1
            End If
        End If
    Next i

    ' 集計結果を配列化（行数確保）
    Dim result As Variant
    Dim key As Variant
    Dim r As Long
    r = 1
    
    ReDim result(1 To dict.Count, 1 To 2)
    
    For Each key In dict.Keys
        result(r, 1) = key
        result(r, 2) = dict(key)
        r = r + 1
    Next key

    ' B列～へ書き戻し
    ws.Range("B1").Resize(dict.Count, 2).Value = result

    MsgBox "カウント完了！", vbInformation

End Sub

※ 結果は上記同じ

CountIf と Dictionary集計の比較

項目CountIfDictionary集計（今回の方法）
判定方式文字列部分一致・ワイルドカード対応完全一致のみ
大文字小文字原則区別なしCompareMode次第
パフォーマンス遅い（行数×判定数）高速（1回走査）
空白処理自動除外自分で制御可能（Trim等）
出力形式単一結果（件数だけ）集計一覧を出力可能
非常に大規模データ処理時間増大高速安定

CompareModeとは

※ Dictionaryでキーを照合するときの大文字・小文字の扱いルール を設定するプロパティ。

CompareModeの設定値

定数動作VBA“APPLE” と “apple” は？
vbBinaryCompare大文字小文字を区別既定違うキーとして扱う
vbTextCompare大文字小文字を区別しない実務推奨同じキーとして扱う

設定方法

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare '大文字小文字を区別しない

※ Dictionary生成後、Addする前に必ず設定すること！

コメント