将唯一值填充到Excel中的VBA数组中

Question

任何人都可以给我一个VBA代码,它将从Excel工作表中获取范围(行或列)并使用唯一值填充列表/数组,即:

table
table
chair
table
stool
stool
stool
chair

当宏运行时会创建一个类似于以下内容的数组:

fur[0]=table
fur[1]=chair
fur[2]=stool

Answer 1

Sub GetUniqueAndCount()

    Dim d As Object, c As Range, k, tmp As String

    Set d = CreateObject("scripting.dictionary")
    For Each c In Selection
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c

    For Each k In d.keys
        Debug.Print k, d(k)
    Next k

End Sub

Answer 2

在这种情况下,我总是使用这样的代码(只需确保您选择的分隔符不是搜索范围的一部分)

Dim tmp As String
Dim arr() As String

If Not Selection Is Nothing Then
   For Each cell In Selection
      If (cell <> "") And (InStr(tmp, cell) = 0) Then
        tmp = tmp & cell & "|"
      End If
   Next cell
End If

If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)

arr = Split(tmp, "|")

Answer 3

结合Tim的Dictionary方法和Jean_Francois下面的变体数组.

你想要的数组是在 objDict.keys

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub

Answer 4

从 MS Excel 365 功能中获益UNIQUE()

为了丰富上面的有效解决方案：

Sub ExampleCall()
Dim rng As Range: Set rng = Sheet1.Range("A2:A11")   ' << change to your sheet's Code(Name)
Dim a: a = rng
a = getUniques(a)
arrInfo a
End Sub

Function getUniques(a, Optional ZeroBased As Boolean = True)
Dim tmp: tmp = Application.Transpose(WorksheetFunction.Unique(a))
If ZeroBased Then ReDim Preserve tmp(0 To UBound(tmp) - 1)
getUniques = tmp
End Function