Поиск уникальных значений (массив)

Опубликовано автор kos20 
'Еще один хороший вариант поиска
Sub Extract_Unique()
    Dim vItem, avArr, li As Long
    Dim Count As Integer
    Count = 0
 
    ReDim avArr(1 To Rows.Count, 1 To 2)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("C1:C" & 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
                avArr(li, 2) = Range("D" & li + Count).Value
 
            Else
               Err.Clear
               Count = Count + 1
 
            End If
        Next
    End With
    If li Then [E11:F11].Resize(li).Value = avArr
 
 
End Sub

Работает!!!!