如何从 Excel VBA 的范围中获取唯一值列表？

Question

我想使用 VBA 获取一个范围内的唯一值列表。 Google 中的大多数示例都是关于使用 VBA 获取列中唯一值的列表。

我不确定如何更改它以获取范围内的值列表。

例如，

Currency    Name 1  Name 2  Name 3  Name 4  Name 5
SGD BGN DBS         
PHP PDSS                
KRW BGN             
CNY CBBT    BGN         
IDA INPC                

我的数组应该是这样的：

BGN, DBS, PDSS, CBBT and INPC.

我该怎么做？需要一些指导。

Answer 1

遍历范围，检查值是否在数组中，如果没有则将其添加到数组中。

Sub test()
Dim Values() As Variant
Values = GetUniqueVals(Selection)
Dim i As Integer
    For i = LBound(Values) To UBound(Values)
        Debug.Print (Values(i))
    Next

End Sub

Function GetUniqueVals(ByRef Data As Range) As Variant()
    Dim cell As Range
    Dim uniqueValues() As Variant
    ReDim uniqueValues(0)

    For Each cell In Data
        If Not IsEmpty(cell) Then
            If Not InArray(uniqueValues, cell.Value) Then
                If IsEmpty(uniqueValues(LBound(uniqueValues))) Then
                    uniqueValues(LBound(uniqueValues)) = cell.Value
                Else
                    ReDim Preserve uniqueValues(UBound(uniqueValues) + 1)
                    uniqueValues(UBound(uniqueValues)) = cell.Value
                End If
            End If
        End If
    Next
    GetUniqueVals = uniqueValues
End Function

Function InArray(ByRef SearchWithin() As Variant, ByVal SearchFor As Variant) As Boolean
    Dim i As Integer
    Dim matched As Boolean 'Default value of boolean is false, we make true only if we find a match

    For i = LBound(SearchWithin) To UBound(SearchWithin)
        If SearchWithin(i) = SearchFor Then matched = True
    Next

    InArray = matched
End Function

Answer 2

我会使用一个简单的VBA-Collection 并添加带有键的项目。键是项目本身，因为不能有重复的键，所以集合将包含唯一值。

注意：因为向集合添加重复键会引发错误，所以将对 collection-add 的调用包装到 on-error-resume-next 中。

函数GetUniqueValues 具有source-range-values 作为参数，并返回唯一的source-range-values 的VBA-Collection。在main 方法中调用该函数并将结果打印到输出窗口中。 HTH。

示例源范围如下所示：

Option Explicit

Sub main()
    Dim uniques As Collection
    Dim source As Range

    Set source = ActiveSheet.Range("A2:F6")
    Set uniques = GetUniqueValues(source.Value)

    Dim it
    For Each it In uniques
        Debug.Print it
    Next
End Sub

Public Function GetUniqueValues(ByVal values As Variant) As Collection
    Dim result As Collection
    Dim cellValue As Variant
    Dim cellValueTrimmed As String

    Set result = New Collection
    Set GetUniqueValues = result

    On Error Resume Next

    For Each cellValue In values
        cellValueTrimmed = Trim(cellValue)
        If cellValueTrimmed = "" Then GoTo NextValue
        result.Add cellValueTrimmed, cellValueTrimmed
NextValue:
    Next cellValue

    On Error GoTo 0
End Function

输出

SGD
PHP
KRW
CNY
IDA
BGN
PDSS
CBBT
INPC
DBS
a

---

如果源范围由区域组成，则首先获取所有区域的值。

Public Function GetSourceValues(ByVal sourceRange As Range) As Collection
    Dim vals As VBA.Collection
    Dim area As Range
    Dim val As Variant
    Set vals = New VBA.Collection
    For Each area In sourceRange.Areas
        For Each val In area.Value
            If val <> "" Then _
                vals.Add val
        Next val
    Next area
    Set GetSourceValues = vals
End Function

源类型现在是 Collection，但所有的工作方式都一样：

Dim uniques As Collection
Dim source As Collection

Set source = GetSourceValues(ActiveSheet.Range("A2:F6").SpecialCells(xlCellTypeVisible))
Set uniques = GetUniqueValues(source)

Answer 3

从 Excel 365 开始，他们引入了UNIQUE() 工作表函数。

来自Microsoft：

UNIQUE 函数返回列表或范围中唯一值的列表。

=UNIQUE(Range,[by_col],[exactly_once])

此公式将在多个单元格中输出唯一值：

所以在A3 中输入公式，我将无法使用B3 或C3，因为它们包含一些结果。

因此，对于 VBA，您只需使用 Evaluate():

Dim uniques as Variant
uniques = Evalute("Unique(" & rng.Address & ",TRUE,FALSE)")

它以数组的形式返回它们（注意：这里的索引从1 开始，而不是0）。

Answer 4

我有类似的需求，想出了以下 VBA 函数，我可以在 VBA 或单元格中使用。优点是您可以疯狂地在参数列表 (=DistinctWS(";", E4:E42, G4:G12)) 中添加范围，并且它适用于旧版 Excel。根据需要进行修改。

Public Function DistinctWS(Delimiter As String, ParamArray r()) As String
    '---create a CSV string that is composed of the distinct values in the ranges
    Dim Rng As Range: Dim C As String:
    Dim i As Integer: Dim j As Integer: Dim st() As String: Dim q As Integer
    For Each rRng In r
        Set Rng = rRng
        For i = 1 To Rng.Areas.count
            For j = 1 To Rng.Areas(i).Cells.count
                C = Rng.Areas(i).Cells(j).Value
                If q = 0 Then
                    ReDim Preserve st(q) As String: st(q) = C: q = q + 1
                    DistinctWS = C
                ElseIf Not IsInArray(C, st) Then
                    ReDim Preserve st(q) As String: st(q) = C: q = q + 1
                    DistinctWS = DistinctWS & Delimiter & C
                End If
            Next j
        Next i
    Next
End Function

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    Dim i As Integer: '   IsInArray = False is default
    For i = LBound(arr) To UBound(arr)
        If arr(i) = stringToBeFound Then
            IsInArray = True: Exit Function
        End If
    Next i
End Function

Answer 5

如果您有 Office 365，则可以使用 Application.WorksheetFunction.Unique 函数快速返回一组唯一值。

例子：

    Dim Uniques As Variant
    Uniques = Application.WorksheetFunction.Unique(your_source_range)

然后将唯一值复制到另一列，例如：

your_destination_range.Value = Uniques