Duplicates in different colors - VBA

[illusionek]

Hello

I have found below code online, which pretty much does what I need with one exception, I would like to exclude blank cells or cells with errors ie #N/A. The end goal is to highlight all duplicated values in different colors.

I am pretty sure I need to use IF statement but I tried couple different variations and nothing works.

Sub Duplicates_Dif_Colors()
    Dim RG As Range
    Dim TT As String
    Dim CL As Range
    Dim CR As String
    Dim CP As Range
    Dim CD As Long
    Dim Cltn As Collection
    Dim J As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      TT = ActiveWindow.RangeSelection.AddressLocal
    Else
      TT = ActiveSheet.UsedRange.AddressLocal
    End If
    Set RG = Application.InputBox("Select the range of data:", "Duplicates with Colors", TT, , , , , 8)
    If RG Is Nothing Then Exit Sub
    CD = 2
    Set Cltn = New Collection
    For Each CL In RG
      On Error Resume Next
      Cltn.Add CL, CL.Text
      If Err.Number = 457 Then
        CD = CD + 1
        Set CP = Cltn(CL.Text)
        If CP.Interior.ColorIndex = xlNone Then CP.Interior.ColorIndex = CD
        CL.Interior.ColorIndex = CP.Interior.ColorIndex
      ElseIf Err.Number = 9 Then
        MsgBox "Found excessive duplicates", vbCritical, "Duplicates with Colors"
        Exit Sub
      End If
      On Error GoTo 0
    Next
End Sub

 

[Alex Blakenburg]

I am sure someone can come up with a better way but in the meantime you can try this:

    Dim RG As Range
    Dim TT As String
    Dim CL As Range
    Dim CR As String
    Dim CP As Range
    Dim CD As Long
    Dim Cltn As Collection
    Dim J As Long
    Dim bNoError As Boolean
    Dim bOKtoProcess As Boolean
    
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      TT = ActiveWindow.RangeSelection.AddressLocal
    Else
      TT = ActiveSheet.UsedRange.AddressLocal
    End If
    Set RG = Application.InputBox("Select the range of data:", "Duplicates with Colors", TT, , , , , 8)
    If RG Is Nothing Then Exit Sub
    CD = 2
    Set Cltn = New Collection
    
    For Each CL In RG
        bNoError = Not IsError(CL)
        bOKtoProcess = False
        If bNoError Then
            If CL <> "" Then
                bOKtoProcess = True
            End If
        End If
        
        If bOKtoProcess Then
            On Error Resume Next
            Cltn.Add CL, CL.Text
            If Err.Number = 457 Then
              CD = CD + 1
              Set CP = Cltn(CL.Text)
              If CP.Interior.ColorIndex = xlNone Then CP.Interior.ColorIndex = CD
              CL.Interior.ColorIndex = CP.Interior.ColorIndex
            ElseIf Err.Number = 9 Then
              MsgBox "Found excessive duplicates", vbCritical, "Duplicates with Colors"
              Exit Sub
            End If
            On Error GoTo 0
        End If
    Next
End Sub