Question

我在这个forumn中找到了这段代码。我想将这个唯一值复制到数组

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

如果你想删除范围中间人，可以使用字典将值直接输入到一维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列E中的唯一值。

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的Collection对象而不是字典的另一种方法。

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

从列中的唯一值创建数组

3 个答案: