Highlight Duplicate Values

Attribute VB_Name = "HighlightDuplicates"
Option Explicit

Public Sub HighlightDuplicates()
    Dim rng As Range
    Dim cell As Range
    Dim counts As Object
    Dim k As Variant

    Set rng = Selection
    Set counts = CreateObject("Scripting.Dictionary")

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            k = CStr(cell.Value)
            If counts.Exists(k) Then
                counts(k) = counts(k) + 1
            Else
                counts(k) = 1
            End If
        End If
    Next cell

    For Each cell In rng
        cell.Interior.ColorIndex = xlColorIndexNone
        If Trim(cell.Value) <> "" Then
            If counts(CStr(cell.Value)) > 1 Then
                cell.Interior.Color = RGB(255, 199, 206)
            End If
        End If
    Next cell

    MsgBox "Duplicate values highlighted in the current selection.", vbInformation
End Sub