Erstellen Sie ein Array aus eindeutigen Werten aus Spalte

Question

Ich habe diesen Code in diesem Herbst gefunden. Ich mag diese eindeutigen Werte in ein Array kopieren

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

Wenn Sie den Bereich Mittelsmann ausschneiden möchten, können Sie die Werte direkt in eine 1-dimensionale VBA-Array erhalten, indem ein Wörterbuch verwenden, um sicherzustellen, dass nur einmalig Werte werden gepackt:

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 

Zum Beispiel wird ein Array zurück UniqueVals("E",sheetName) bestehend aus den eindeutigen Werte in der Spalte E von Sheetname.

Answer 2

Eine andere Version, die auch ein Wörterbuch verwendet. Es funktioniert für mich, aber ich muss zugeben, dass immer noch nicht wissen, wie es funktioniert (ich bin ein Anfänger). Ich habe diesen Code irgendwo in Stackoverflow gefunden, kann aber den Ort nicht finden.

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

Hier ist eine andere Methode, die VBA-Collection-Objekt anstelle eines Wörterbuchs verwendet.

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