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

'-------------------------------------------------------------
' 選択セル範囲の重複データのセルを色分けするマクロ
'-------------------------------------------------------------
' 選択セル範囲内の重複データを検索し色を付けるマクロです。
' 選択範囲が複数ある場合にも対応しており20色まで色分けします。
'［掲載ページ］
' https://excel.syogyoumujou.com/vba/overlap.html
'［作成日］2010.06.09　［更新日］2023.11.18
'-------------------------------------------------------------
Sub ColorDuplicateCells()
    '---------------------------------------
    ' セルを選択しているか確認
    '---------------------------------------
    If TypeName(Application.Selection) <> "Range" Then
        MsgBox "セル範囲を選択してください。", vbExclamation + vbOKOnly
        Exit Sub
    End If
    
    '---------------------------------------
    ' 対象セル範囲取得
    '---------------------------------------
    Dim i           As Long
    Dim lngCount    As Long
    Dim rngTarget() As Range
    
    For i = 1 To Selection.Areas.Count
        If Not Intersect(Selection.Areas(i), ActiveSheet.UsedRange) Is Nothing Then
            '選択セル範囲と使用セル範囲の共通セルを取得
            lngCount = lngCount + 1
            ReDim Preserve rngTarget(1 To lngCount)
            Set rngTarget(lngCount) = Intersect(Selection.Areas(i), ActiveSheet.UsedRange)
        End If
    Next
    
    '---------------------------------------
    ' 連想配列にデータを登録
    '---------------------------------------
    Dim rng        As Range
    Dim strData    As String
    Dim strAddress As String
    Dim objDic     As Object
    
    '連想配列生成
    Set objDic = CreateObject("Scripting.Dictionary")
    
    For i = 1 To lngCount
        For Each rng In rngTarget(i)
            strData = CStr(rng.Value)
            If 0 < Len(strData) Then
                strAddress = rng.Address(False, False)
                If objDic.Exists(strData) Then
                    '連想配列にデータが登録されている場合（重複有り）
                    '登録されているセルアドレスを取得し新規セルアドレスと連結
                    strAddress = objDic.Item(strData) & "," & strAddress
                    
                    '登録されているデータを削除
                    objDic.Remove strData
                    
                    'データと連結したセルアドレスを再登録
                    objDic.Add strData, strAddress
                Else
                    '連想配列に該当データが存在しない場合
                    '該当データとセルアドレスを連想配列に登録
                    objDic.Add strData, strAddress
                End If
            End If
        Next
    Next
    
    '重複データがなければ終了
    If objDic.Count = 0 Then GoTo NO_DATA

    '---------------------------------------
    ' 連想配列の中から重複データのみ取得
    '---------------------------------------
    Dim lngDataCount       As Long
    Dim strDuplicateData() As String
    Dim varKeys            As Variant
    
    varKeys = objDic.Keys

    For i = LBound(varKeys) To UBound(varKeys)
        '登録データにカンマがある場合は重複データ
        If 0 < InStr(1, objDic.Item(varKeys(i)), ",") Then
            ReDim Preserve strDuplicateData(lngDataCount)
            strDuplicateData(lngDataCount) = objDic.Item(varKeys(i))
            lngDataCount = lngDataCount + 1
        End If
    Next
    
    '対象データがなければ終了
    If lngDataCount = 0 Then GoTo NO_DATA

    '---------------------------------------
    ' 重複セルに色を付ける
    '---------------------------------------
    Dim varSplit   As Variant
    Dim varAddress As Variant
    For i = 0 To UBound(strDuplicateData)
        If 200 < Len(strDuplicateData(i)) Then
            'セルアドレスの文字数が200文字を超えた場合はアドレスを分割し色付け
            varSplit = Split(strDuplicateData(i), ",")
            For Each varAddress In varSplit
                Range(varAddress).Interior.ColorIndex = (i Mod 20) + 34
            Next
        Else
            '対象セルアドレスに一括色付け
            Range(strDuplicateData(i)).Interior.ColorIndex = (i Mod 20) + 34
        End If
    Next
    Exit Sub
    
NO_DATA:
    MsgBox "重複データはありません。", vbInformation + vbOKOnly
End Sub