在基于用户的选择中查找所有不同的值 - Excel VBA

Posted 2023-03-22

【中文标题】在基于用户的选择中查找所有不同的值 - Excel VBA

【英文标题】：Find all distinct values in user based selection - Excel VBA

【发布时间】：2014-02-05 20:02:00

【问题描述】：

有没有一种快速简便的方法来使用 VBA 在 Excel 中选择给定选择中的所有不同值？

0 | we | 0
--+----+--
we| 0  | 1

-> 结果应该是 0,we,1

提前非常感谢

【问题讨论】：

使用字典优于集合。

【参考方案1】：

试试这个：

Sub Distinct()
    Dim c As Collection
    Set c = New Collection
    Dim r As Range
    Dim dis As Range
    Set dis = Nothing
    For Each r In Selection
        If r.Value <> "" Then
            On Error Resume Next
            c.Add r.Value, CStr(r.Value)
            If Err.Number = 0 Then
                If dis Is Nothing Then
                    Set dis = r
                Else
                    Set dis = Union(dis, r)
                End If
            End If
            Err.Number = 0
            On Error GoTo 0
        End If
    Next r
dis.Select
End Sub

【讨论】：

代码什么都不做（什么都没有发生），我在哪里可以看到结果？

@TomStevens 在运行此之前，您需要选择所有数据，然后在运行后只选择不同的选择。

【参考方案2】：

顺便说一句，我找到了另一个解决方案：

Option Explicit

Public Sub Test()
    Dim cell As Object
    Dim d As Object

    Set d = CreateObject("Scripting.Dictionary")    
    For Each cell In Selection
        d(cell.Value) = 1
    Next cell

    MsgBox d.count & " unique item(s) in selection (" & Join(d.Keys, ",") & ")"
End Sub

【参考方案3】：

另一种方法是创建一个用户函数。以下函数将返回一个包含所有不同值的行数组。

Function ReturnDistinct(InpRng)
    Dim Cell As Range
    Dim i As Integer
    Dim DistCol As New Collection
    Dim DistArr()

    If TypeName(InpRng) <> "Range" Then Exit Function

    'Add all distinct values to collection
    For Each Cell In InpRng
        On Error Resume Next
        DistCol.Add Cell.Value, CStr(Cell.Value)
        On Error GoTo 0
    Next Cell

    'Write collection to array
    ReDim DistArr(1 To DistCol.Count)
    For i = 1 To DistCol.Count Step 1
        DistArr(i) = DistCol.Item(i)
    Next i

    ReturnDistinct = DistArr
End Function

代码利用了您只能向集合添加不同值的事实。否则会返回错误。

通过在至少足够大以包含不同值的范围上使用此函数，它将列出输入范围中的不同值。使用应返回矩阵的函数时，请记住使用 Ctrl+Shift+Enter。