"如何从 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                

Answer 1

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

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

函数GetUniqueValues将source-range-values作为参数并返回VBA-Collection of unique source-range-values 。 在main方法中调用该函数并将结果打印到输出窗口中。 哈。

样本源范围如下所示：

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 2

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

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 3

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

来自微软：

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

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

例子：

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

Answer 5

我有类似的需求，并提出了以下我可以在 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