Поиск уникальных значений VBA

Sub DictionaryUniq()
Dim x, arr, y, i As Long, Rng As Range, t As Single
' Это не включаем в затраты метода (одинаково для всех)
With Columns(1)
.Cells(Rows.Count, 1) = Empty
Set Rng = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
Columns(2).ClearContents
' Тестируем только сам метод без общих для всех методов
' затрат времени на взаимодействие с тестовым диапазоном
t = Timer
arr = Rng.Value
If IsArray(arr) Then
 With CreateObject("Scripting.Dictionary") ' Позднее связывание
'With New Dictionary ' Раннее связывание, нужен Reference на MS Scripting Runtime
.CompareMode = vbTextCompare
ReDim y(1 To UBound(arr), 1 To 1)
For Each x In arr
If Len(x) > 0 Then
If Not .Exists(x) Then
.Add x, 0
i = i + 1
y(i, 1) = x
End If
End If
Next
'Uniq_1D_Array = .Keys ' так можно получить сразу весь массив уникальных
End With
End If
Debug.Print Timer - t ' Дальше идут общие для всех методов затраты времени на запись результата
With Application
.EnableEvents = False
.ScreenUpdating = False
Rng.Offset(, 1).Value = y
'[Время].Offset(, 1).Value = t
'[Время].Offset(1, 1).Value = Rng.Rows.Count / t
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub



'Еще один хороший вариант поиска
Sub Extract_Unique()
    Dim vItem, avArr, li As Long
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("F2:F" & shd.Cells.SpecialCells(xlLastCell).Row)
        'Cells(Rows.Count, 1).End(xlUp) - определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    If li Then [O2].Resize(li).Value = avArr
End Sub