Пошук дублікатів в Excel по стовпцю з активною коміркою

Одного разу мені знадобилося визначити чи є в тому чи іншому стовпці таблиці Excel дублікати. Тому я вирішив написати код на VBA з наступним алгоритмом:

1. При запуску макроса,  відбувається визначення в якому стовпці знаходиться активна комірка.
2. Відбувається визначення всіх заповнених комірок в цьому стовпці.
3. Відбувається порівнювання значень в комірках.
4. Якщо є співпадіння, то колір заливки комірки змінюється. Причому для кожного унікального співпадіння колір також має бути унікальним. Адже так буде легше аналізувати дані.

Код VBA для порівняння комірок Excel

Sub Порівняння_комірок()
    ' Визначаємо в якій колонці знаходиться активна комірка
    Dim activeColumn As Integer
    activeColumn = ActiveCell.Column

    ' Визначаємо останню заповнену комірку в колонці
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, activeColumn).End(xlUp).Row

    ' Зберігаємо значення комірок та їх адресу в словнику
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim cell As Range
    Dim cellValue As Variant
    
    ' Створюємо список кольорів
    Dim colors As Variant
    colors = Array(RGB(255, 255, 0), RGB(144, 238, 144), RGB(173, 216, 230), RGB(255, 182, 193), RGB(255, 165, 0), RGB(221, 160, 221))
    
    Dim colorIndex As Integer
    colorIndex = 0
    
    For Each cell In Range(Cells(1, activeColumn), Cells(lastRow, activeColumn))
        cellValue = cell.Value
        If Not IsEmpty(cellValue) Then
            If dict.exists(cellValue) Then
                dict(cellValue) = dict(cellValue) & "," & cell.Address
            Else
                dict.Add cellValue, cell.Address
            End If
        End If
    Next cell

    ' Виділяємо комірки з однаковими значеннями різними кольорами
    Dim addresses As String
    For Each cellValue In dict.Keys
        addresses = dict(cellValue)
        If InStr(addresses, ",") > 0 Then ' Перевірка, чи є дублікати
            Range(addresses).Interior.Color = colors(colorIndex Mod (UBound(colors) + 1))
            colorIndex = colorIndex + 1
        End If
    Next cellValue
End Sub