トップ　>　汎用コード　>　重複データを検索する

'***************************************************************
'* 選択セル範囲の重複データのセルを色分けする
'*--------------------------------------------------------------
'* 概要     | 選択セル範囲内の重複データを検索し色を付ける
'*          | 選択範囲が複数ある場合にも対応し20色まで色分けする
'*          | 参考：https://excel.syogyoumujou.com/vba/overlap.html
'* 引数     | なし
'* 戻り値   | なし
'* 作成日   | 2010.06.09
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.22
'***************************************************************
Public Sub highlightDuplicateCells()
On Error GoTo LBL_ERROR

    '------------------------------
    ' セル選択確認
    '------------------------------
    If TypeName(Application.Selection) <> "Range" Then
        MsgBox "セル範囲を選択してください", vbExclamation + vbOKOnly
        Exit Sub
    End If

    '------------------------------
    ' シートの保護確認
    '------------------------------
    If ActiveSheet.ProtectContents Then
        MsgBox "シートの保護を解除してください", vbExclamation + vbOKOnly
        Exit Sub
    End If

    '------------------------------
    ' セル範囲を集合
    '------------------------------
    ' セル範囲を複数選択している場合はセルを集合する
    Dim rngArea   As Range
    Dim rngTarget As Range
    For Each rngArea In Selection.Areas
        If rngTarget Is Nothing Then
            Set rngTarget = rngArea
        Else
            Set rngTarget = Union(rngArea, rngTarget)
        End If
    Next rngArea

    '------------------------------
    ' 重複値とセルアドレスを取得
    '------------------------------
    Dim dicDup As Object
    '《セル範囲の重複値とセルアドレスを Dictionary で取得》
    ' ** 引数：対象セル範囲
    '  戻り値：重複値とセルアドレスが登録された Dictionary オブジェクト
    Set dicDup = getDuplicateValuesAsDictionary(rngTarget)

    If dicDup.Count = 0 Then
        MsgBox "重複データはありません。", vbInformation
        Exit Sub
    End If

    '------------------------------
    ' 重複セルに色設定
    '------------------------------
    Dim lngCount   As Long
    Dim varKey     As Variant
    Dim varSplit   As Variant
    Dim varAddress As Variant

    For Each varKey In dicDup
        If 200 < Len(dicDup.Item(varKey)) Then
            ' セルアドレスの文字数が200文字を超えている場合はアドレスを分割し色付け
            varSplit = Split(dicDup.Item(varKey), ",")
            For Each varAddress In varSplit
                Range(varAddress).Interior.ColorIndex = (lngCount Mod 20) + 34
            Next varAddress
        Else
            ' 対象セルアドレスに一括色付け
            Range(dicDup.Item(varKey)).Interior.ColorIndex = (lngCount Mod 20) + 34
        End If
        lngCount = lngCount + 1
    Next varKey
    Exit Sub

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    MsgBox "エラー番号：" & Err.Number & vbLf & Err.Description, vbExclamation
End Sub

'***************************************************************
'* セル範囲の重複値とセルアドレスをDictionaryで返す
'*--------------------------------------------------------------
'* 概要     | 指定したセル範囲の重複した値とセルアドレスを
'*          | Dictionaryオブジェクトで返す
'*          | 参考：https://excel.syogyoumujou.com/vba/overlap.html
'* 引数     | 1) pRngTarget：対象セル範囲（ByRef）
'* 戻り値   | Object型（Dictionaryオブジェクト）
'*          | 成功  ：Key ：重複値
'*          |         Item：セルアドレス
'*          |               （例：A1,B2,D4）
'*          | エラー：Nothing
'* 作成者   | S.Kubo
'* 作成日   | 2024.04.12
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.22
'***************************************************************
Public Function getDuplicateValuesAsDictionary(ByRef pRngTarget As Range) As Object
On Error GoTo LBL_ERROR

    '------------------------------
    ' Dictionaryオブジェクトを生成
    '------------------------------
    Dim dic    As Object
    Dim dicDup As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set dicDup = CreateObject("Scripting.Dictionary")

    '------------------------------
    ' 対象セル範囲を適正化
    '------------------------------
    ' シートの使用セル範囲と対象セルの共通セルを取得
    Set pRngTarget = Intersect(pRngTarget.Worksheet.UsedRange, pRngTarget)
    If pRngTarget Is Nothing Then Exit Function

    '------------------------------
    ' 重複値とセルアドレスを取得
    '------------------------------
    Dim rng        As Range
    Dim var        As Variant
    Dim strAddress As String

    For Each rng In pRngTarget
        ' セル値を変数に代入（エラー値の場合は表示テキストを代入）
        If IsError(rng) Then var = rng.Text Else var = rng.Value

        If Not IsEmpty(var) Then
            ' 値がEmpty以外の場合
            If Not dic.Exists(var) Then
                ' dic に値が未登録の場合は dic に値とセルアドレスを登録
                dic.Add var, rng.Address(False, False)
            Else
                ' dic に値が登録されている場合はその値は重複値のため dicDup に登録
                If Not dicDup.Exists(var) Then
                    ' dicDup に値が未登録の場合は値とセルアドレスを登録
                    dicDup.Add var, dic.Item(var) & "," & rng.Address(False, False)
                Else
                    ' dicDup に値が登録されている場合はセルアドレスを追加
                    strAddress = dicDup(var)
                    dicDup(var) = strAddress & "," & rng.Address(False, False)
                End If
            End If
        End If
    Next rng

    ' 重複値の登録がない場合は抜ける
    If dicDup.Count = 0 Then Exit Function

    '------------------------------
    ' 戻り値設定
    '------------------------------
    Set getDuplicateValuesAsDictionary = dicDup
    Exit Function

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    Set getDuplicateValuesAsDictionary = Nothing
End Function