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

'--------------------------------------------------------------------------
' 選択セル範囲の重複データのセルを色分けするマクロ
'--------------------------------------------------------------------------
' 選択セル範囲内の重複データを検索し色を付けるマクロです。
' 選択範囲が複数ある場合にも対応しており20色まで色分けします。
'［掲載ページ］
' https://excel.syogyoumujou.com/vba/overlap.html
'［作成日］2010.06.09　［更新日］2025.09.19
'--------------------------------------------------------------------------
Sub setColorDuplicateCells()

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
    
    '-----------------------------
    ' 重複値とセルアドレスを取得
    '-----------------------------
    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
        Else
            ' 対象セルアドレスに一括色付け
            Range(dicDup.Item(varKey)).Interior.ColorIndex = (lngCount Mod 20) + 34
        End If
        lngCount = lngCount + 1
    Next
    
    Exit Sub
'-----------------------------
' エラー処理
'-----------------------------
LBL_ERROR:
    MsgBox "エラー番号：" & Err.Number & vbLf & Err.Description, vbExclamation
End Sub

'--------------------------------------------------------------------------
' セル範囲の重複値とセルアドレスを Dictionary で取得
'--------------------------------------------------------------------------
'［引数］
'   rngTarget：対象セル範囲
'［戻り値］
'   Dictionaryオブジェクト
'       Key ：重複値
'       Item：セルアドレス（Itemに設定されるセルアドレス例：A1,B2,D4）
'［作成日］2024.04.12　［更新日］2025.09.19
'--------------------------------------------------------------------------
Function getDuplicateValuesAsDictionary(ByRef rngTarget As Range) As Object

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

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

    '-----------------------------
    ' 重複値とセルアドレスを取得
    '-----------------------------
    Dim rng        As Range
    Dim var        As Variant
    Dim strAddress As String
    
    For Each rng In rngTarget
        ' セル値を変数に代入（エラー値の場合は表示テキストを代入）
        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
    ' 重複値の登録がない場合は抜ける
    If dicDup.Count = 0 Then Exit Function
    
    '-----------------------------
    ' 戻り値設定
    '-----------------------------
    Set getDuplicateValuesAsDictionary = dicDup
End Function