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

'------------------------------------------------------------------------------
' 選択セル範囲の重複データのセルを色分けするマクロ
'------------------------------------------------------------------------------
' 選択セル範囲内の重複データを検索し色を付けるマクロです。
' 選択範囲が複数ある場合にも対応しており20色まで色分けします。
'［掲載ページ］
' https://excel.syogyoumujou.com/vba/overlap.html
'［作成日］2010.06.09　［更新日］2024.04.13
'------------------------------------------------------------------------------
Sub setColorDuplicateCells()
    '------------------------------------------
    ' セルを選択しているか確認
    '------------------------------------------
    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
    Set dicDup = getDuplicateValuesAsDictionary(rngTarget)
    If dicDup.Count = 0 Then
        MsgBox "重複データはありません。", vbInformation + vbOKOnly
        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
End Sub

'------------------------------------------------------------------------------
' 対象セル範囲の重複値とセルアドレスを取得する関数
'------------------------------------------------------------------------------
' 引数に指定したセル範囲の重複した値とセルアドレスを取得
'［引数］
'   rngTarget：対象セル範囲
'［戻り値］
'   Dictionaryオブジェクト
'       Key ：重複値
'       Item：セルアドレス（Itemに設定されるセルアドレス例：A1,B2,D4）
'［作成日］2024.04.12
'------------------------------------------------------------------------------
Function getDuplicateValuesAsDictionary(ByRef rngTarget As Range) As Object
    '--------------------------------------
    ' 戻り値のDictionaryオブジェクトを生成
    '--------------------------------------
    Set getDuplicateValuesAsDictionary = CreateObject("Scripting.Dictionary")
    
    '--------------------------------------
    ' 対象セル範囲を適正化
    '--------------------------------------
    ' シートの使用セル範囲と対象セルの共通セルを取得
    Set rngTarget = Intersect(rngTarget.Worksheet.UsedRange, rngTarget)
    If rngTarget Is Nothing Then Exit Function
    
    '--------------------------------------
    ' 重複値とセルアドレスを取得
    '--------------------------------------
    ' Dictionaryオブジェクトを生成
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    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
        
        ' 値がEmpty以外の場合は重複確認対象
        If Not IsEmpty(var) Then
            If Not dic.Exists(var) Then
                ' dicに値が未登録の場合は dicに値とセルアドレスを登録
                dic.Add var, rng.Address(False, False)
            Else
                ' dicに値が登録されている場合は 重複値として 戻り値に値を設定
                If Not getDuplicateValuesAsDictionary.Exists(var) Then
                    ' 戻り値に値が未登録の場合は 戻り値に値とセルアドレスを登録
                    getDuplicateValuesAsDictionary.Add var, dic.Item(var) & "," & rng.Address(False, False)
                Else
                    ' 戻り値に値が登録されている場合は 登録されていセルアドレスにセルアドレスを追加
                    strAddress = getDuplicateValuesAsDictionary.Item(var)
                    getDuplicateValuesAsDictionary.Remove var
                    getDuplicateValuesAsDictionary.Add var, strAddress & "," & rng.Address(False, False)
                End If
            End If
        End If
    Next
End Function