Option Explicit
Sub MegaArray()
    Dim Base() As Variant, Base2() As Variant
    Dim TimeS As Variant, TimeE As Variant
    Base = ActiveSheet.Cells(1, 1).Resize(600000, 1).Value
    Base2 = Base
    TimeS = Time
    Debug.Print "CollectionUniq start:   " & UBound(Base) & " " & Date & " " & TimeS
    CollectionUniq Base
    TimeE = Time
    Debug.Print "CollectionUniq end: " & UBound(Base) + 1 & " " & Date & " " & TimeE
    TimeS = Time
    Debug.Print "DictionaryUniq start:   " & UBound(Base2) & " " & Date & " " & TimeS
    DictionaryUniq Base2
    TimeE = Time
    Debug.Print "DictionaryUniq end: " & UBound(Base2) + 1 & " " & Date & " " & TimeE
    
End Sub
Public Sub CollectionUniq(ByRef StringArray() As Variant)
  Dim x, y, arr, i As Long
  
  ReDim arr(LBound(StringArray) To UBound(StringArray))
  arr = StringArray
  If IsArray(arr) Then
    ReDim y(0 To UBound(arr))
    With New Collection
      On Error Resume Next
      For Each x In arr
        If Len(x) > 0 Then
          Err.Clear
          .Add 0, CStr(x)
          If Err = 0 Then
            y(i) = x
            i = i + 1
          End If
        End If
      Next
    End With
  End If
  
  If y(i) = Empty Then
  ReDim Preserve y(0 To i - 1)
  End If
StringArray = y
End Sub
Public Sub DictionaryUniq(ByRef StringArray() As Variant)
  Dim x, arr, y, i As Long
  Dim Uniq_1D_Array() As Variant
  ReDim arr(LBound(StringArray) To UBound(StringArray))
  arr = StringArray
  
  If IsArray(arr) Then
    'With CreateObject("Scripting.Dictionary") ' Позднее связывание
    With New Dictionary ' Раннее связывание, нужен Reference на MS Scripting Runtime
      .CompareMode = vbTextCompare
      ReDim y(0 To UBound(arr))
      For Each x In arr
        If Len(x) > 0 Then
          If Not .Exists(x) Then
            .Add x, 0
            i = i + 1
            y(i) = x
          End If
        End If
      Next
      Uniq_1D_Array = .Keys  ' так можно получить сразу весь массив уникальных
    End With
  End If
  
StringArray = Uniq_1D_Array
End Sub