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

Question

我希望使用VBA获取范围内的唯一值列表。谷歌上的大多数示例都是使用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.

我该如何做？需要一些指导。

- lakshmen

---

如果您想要一个严格基于VBA的解决方案，请查看Scripting.Dictionary的Exists方法。 - user4039065

相关内容：https：//stackoverflow.com/questions/36044556/quicker-way-to-get-all-unique-values-of-a-column-in-vba - Jens Mühlenhoff

Answer 1

我会使用一个简单的VBA-Collection，并通过 key 添加每个项。因为 key 本身不能重复，所以集合中将包含唯一的值。

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

函数 GetUniqueValues 的参数是 source-range-values，返回一个包含唯一源范围值的VBA-Collection。在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

数据源类型现在是集合，但是所有操作都是一样的：

Dim uniques As Collection
Dim source As Collection

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

- Daniel Dušek

---

当一个范围是一个连续的块时，这个方法非常有效，但是当范围被“分开”时，例如一些行被隐藏并且定义为： uniques = Range.SpecialCells(xlCellTypeVisible) 这种情况下就会失败。你有什么想法可以让它仍然有效吗？ - Da Spotz

我找到了一个解决方法。通过将“拆分”的范围的值添加到数组中，然后将数组元素添加到集合中，而不是使用这种方法仍然可以工作（需要进行小的调整）。 - Da Spotz

@DaSpotz 请查看已编辑的答案。在使用 SpecialCells 时必须考虑到区域。否则它的工作方式是相同的。希望对你有所帮助。 - Daniel Dušek

@DaSpotz 没关系！是的，Areas不是那么出名，但很容易使用并且知道它们很有用。 - Daniel Dušek

但是由于默认属性，它也应该在没有“Value”的情况下工作。但我个人不使用它们。 - Daniel Dušek

Answer 2

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

例如：

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

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

your_destination_range.Value = Uniques

- cyberponk

---

谢谢您注意到这个问题！我相信在365中，您也可以使用公式=UNIQUE(range)。 - BruceWayne

Answer 3

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

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

- CBRF23

Answer 4

截至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）。

- BruceWayne

---

在Office 365上对我没有起作用。它没有返回唯一的值，只是按顺序列出了范围内的值列表。 - cyberponk

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

- Danny Holstein