Уникальные дубликаты

Опубликовано автор kos20 
Sub getTheSame()
    On Error GoTo errh: 'Устанавливаем хендлер ошибок
    Set h = CreateObject("Scripting.dictionary") 'Создаем хеш - множество пар "ключ" -> значение
    Dim rg As Range
    Count = 0
     ReDim avArr(1 To Rows.Count, 1 To 2)
     ReDim tempArr(1 To 10)
    j = 0
    Set rg = Columns(1).Cells.SpecialCells(xlCellTypeConstants) 'Берем только константы из колонки 1
    For Each c In rg.Cells 'Перебираем все ячейки из множества
        DoEvents 'Даем Экселю возможность отрисоваться
        ActiveWindow.Caption = c.Address 'Можно еще адрес ячейки показывать - чтоб был виден прогресс
        h(c.Value) = h(c.Value) + 1 ' Если ключ не существовал, хеш его автоматически добавит, иначе увеличит к-во повторений ключа
        If h(c.Value) > 1 Then 'Если ключ встречался более 1 раза
            c.Offset(0, 1).Value = "Exists" 'Ставим в соседней ячейке Exists
 
            j = j + 1
            tempArr(j) = c.Value
        End If
    Next c
 
    Set h = Nothing 'Освобождаем память из под хеша
    MsgBox "Done", vbInformation ' Ну и для наглядности плакат об окончании
    '=============================
    If 0 Then 'Сюда попадем только в случае ошибки
errh:       'В обычных условиях if 0 никогда не сработает
        Set h = Nothing 'Если возникла ошибка - освобождаем память из под хеша
        MsgBox Err.Description 'Выводим сообщение об ошибке
    End If
    '==============================
 
    ReDim avArr(1 To Rows.Count, 1 To 2)
        With New Collection
        On Error Resume Next
        For Each vItem In tempArr
        'Cells(Rows.Count, 1).End(xlUp) - определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1
                avArr(li, 1) = vItem: Debug.Print vItem
            Else
               Err.Clear
               Count = Count + 1
            End If
        Next
    End With
 
 
     If