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

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

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

函数GetUniqueValues将 source-range-values 作为参数，并返回唯一的源范围值的VBA-Collection。在main方法中调用该函数，并将结果打印到Output-Window中。 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 2

从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 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

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

3 个答案: