Создайте массив из уникальных значений из столбца

Question

Я нашел этот код в этой колонке. Я хочу, чтобы скопировать эти уникальные значения в массив

Dim sheetName As String 
sheetName = Application.InputBox("Enter Sheet Name") 

Sheets(sheetName).Range("E:E").AdvancedFilter Action:=xlFilterCopy, _ 
CopyToRange:=Sheets(sheetName).Range("O:O"), unique:=True 

Answer 1

Если вы хотите, чтобы вырезать диапазон посредник, вы можете получить значения непосредственно в 1-мерный массив VBA, используя словарь, чтобы убедиться, что только уникальным значения захватываются:

Function UniqueVals(Col As Variant, Optional SheetName As String = "") As Variant 
    'Return a 1-based array of the unique values in column Col 

    Dim D As Variant, A As Variant, v As Variant 
    Dim i As Long, n As Long, k As Long 
    Dim ws As Worksheet 

    If Len(SheetName) = 0 Then 
     Set ws = ActiveSheet 
    Else 
     Set ws = Sheets(SheetName) 
    End If 

    n = ws.Cells(Rows.Count, Col).End(xlUp).Row 
    ReDim A(1 To n) 
    Set D = CreateObject("Scripting.Dictionary") 

    For i = 1 To n 
     v = ws.Cells(i, Col).Value 
     If Not D.Exists(v) Then 
      D.Add v, 0 
      k = k + 1 
      A(k) = k 
     End If 
    Next i 

    ReDim Preserve A(1 To k) 
    UniqueVals = A 

End Function 

Например, UniqueVals("E",sheetName) возвращает массив, состоящий из уникальных значений в столбце Е SheetName.

Answer 2

Другая версия, также используя словарь. Это работает для меня, но я должен признать, что до сих пор не знаю, как это работает (я новичок). Я нашел этот код где-то в Stackoverflow, но не могу определить место.

Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long 
Dim i As Integer 

Private Sub Go_Click() 
    Set dU1 = CreateObject("Scripting.Dictionary") 
    lrU = Cells(Rows.Count, 1).End(xlUp).Row 
    cU1 = Range("E1:E" & lrU) 
    For iU1 = 1 To UBound(cU1, 1) 
     dU1(cU1(iU1, 1)) = 1 
    Next iU1 

    For i = 0 To dU1.Count - 1 
     MsgBox "dU1 has " & dU1.Count & " elements and key#" & i & " is " & dU1.Keys()(i) 
    Next 
End Sub 

Answer 3

Вот еще один метод с использованием объекта коллекции VBA вместо словаря.

Sub Dural() 
    Dim sheetName As String 
    Dim V As Variant, COL As Collection 
    Dim I As Long 
    Dim vUniques() As Variant 

sheetName = Application.InputBox("Enter Sheet Name") 

'Copy all data into variant array 
' This will execute significantly faster than reading directly 
' from the Worksheet range 

With Worksheets(sheetName) 
    V = .Range(.Cells(1, "E"), .Cells(.Rows.Count, "E").End(xlUp)) 
End With 

'Collect unique values 
'Use the key property of the collection object to 
' ensure no duplicates are collected 
' (Trying to assign the same key to two items fails with an error 
' which we ignore) 
Set COL = New Collection 
On Error Resume Next 
For I = 1 To UBound(V, 1) 
    COL.Add Item:=V(I, 1), Key:=CStr(V(I, 1)) 
Next I 
On Error GoTo 0 

'write collection to variant array 
ReDim vUniques(1 To COL.Count) 
For I = 1 To COL.Count 
    vUniques(I) = COL(I) 
Next I 

Stop 

End Sub