VBA If Duplicate(s) Found then MsgBox One Time Only

[rsmeyerson]

Hello,

I would like help adjusting my code to open a message box if duplicate(s) are found in Column A. The code below opens a message box at each occurrence of a duplicate. I would like the message box to open only once if one or more duplicates are found. Thank you for your help.

Sub HighlightDuplicates()
    Dim cel As Variant
    Dim myrng As Range
    Dim clr As Long
    Set myrng = Range("A2:A" & Range("A65536").End(xlUp).Row)
    myrng.Interior.ColorIndex = xlNone
    clr = 3
    
With Sheets("RtlBack")
        For Each cel In myrng
            If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
                MsgBox "Duplicate Found"
                If WorksheetFunction.CountIf(Range("A2:A" & cel.Row), cel) = 1 Then
                    cel.Interior.ColorIndex = clr
                    cel.Interior.TintAndShade = 0.6
                    clr = clr + 1
                Else
                    cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
                    cel.Interior.TintAndShade = 0.6
                End If
            End If
        Next
End With

End Sub

 

[Trebor76]

Hi rsmeyerson,

Try this:

Option Explicit
Sub HighlightDuplicates()
    Dim cel As Variant
    Dim myrng As Range
    Dim clr As Long
    Dim clnMyValues As New Collection
    Set myrng = Range("A2:A" & Range("A65536").End(xlUp).Row)
    myrng.Interior.ColorIndex = xlNone
    clr = 3
    
With Sheets("RtlBack")
        For Each cel In myrng
            If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
                On Error Resume Next
                    clnMyValues.Add cel, CStr(cel)
                    If Err.Number = 0 Then
                        MsgBox "Duplicate Found"
                    End If
                On Error GoTo 0
                If WorksheetFunction.CountIf(Range("A2:A" & cel.Row), cel) = 1 Then
                    cel.Interior.ColorIndex = clr
                    cel.Interior.TintAndShade = 0.6
                    clr = clr + 1
                Else
                    cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
                    cel.Interior.TintAndShade = 0.6
                End If
            End If
        Next
End With

End Sub

Regards,

Robert

 

[rsmeyerson]

Thank you. In the sample sheet on which I'm running this code, there three separate sets of duplicates (each with two identical numbers). Your code results in three, successive openings of the message box (one at each duplicate). Is it possible to only open the message box when the first set of duplicates is identified?

 

[Trebor76]

Maybe this:

Option Explicit
Sub HighlightDuplicates()
    Dim cel As Variant
    Dim myrng As Range
    Dim clr As Long
    Dim blnDupsFound As Boolean
    Set myrng = Range("A2:A" & Range("A65536").End(xlUp).Row)
    myrng.Interior.ColorIndex = xlNone
    clr = 3
    
With Sheets("RtlBack")
        For Each cel In myrng
            If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
                If blnDupsFound = False Then
                    MsgBox "Duplicate Found"
                    blnDupsFound = True
                End If
                If WorksheetFunction.CountIf(Range("A2:A" & cel.Row), cel) = 1 Then
                    cel.Interior.ColorIndex = clr
                    cel.Interior.TintAndShade = 0.6
                    clr = clr + 1
                Else
                    cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
                    cel.Interior.TintAndShade = 0.6
                End If
            End If
        Next
End With

End Sub

 

[rsmeyerson]

This is exactly what I needed. Thank you very much!

 

[Trebor76]

Thanks for lettings us know and you're welcome