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

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

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

->结果应该是{0，we，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

Sub-Distinct（）
Dim c作为集合
集合c=新集合
调光范围
Dim dis As范围
设置dis=无
对于选择中的每个r
如果r.值为“”，则
出错时继续下一步
c、 加上r.值，CStr（r.值）
如果Err.Number=0，则
如果dis什么都不是
设置dis=r
其他的
设置dis=并集（dis，r）
如果结束
如果结束
错误号=0
错误转到0
如果结束
下一个r
dis.选择
端接头

尝试一下：

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

Sub-Distinct（）
Dim c作为集合
集合c=新集合
调光范围
Dim dis As范围
设置dis=无
对于选择中的每个r
如果r.值为“”，则
出错时继续下一步
c、 加上r.值，CStr（r.值）
如果Err.Number=0，则
如果dis什么都不是
设置dis=r
其他的
设置dis=并集（dis，r）
如果结束
如果结束
错误号=0
错误转到0
如果结束
下一个r
dis.选择
端接头

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

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

函数返回不同（InpRng）
暗淡单元格作为范围
作为整数的Dim i
Dim DistCol作为新系列
Dim DistArr（）
如果TypeName（InpRng）“Range”，则退出函数
'将所有不同的值添加到集合
对于InpRng中的每个单元
出错时继续下一步
DistCol.Add Cell.Value，CStr（Cell.Value）
错误转到0
下一个细胞
'将集合写入数组
重拨DistArr（1到DistCol.Count）
对于i=1到DistCol.Count步骤1
DistArr（i）=DistCol.项目（i）
接下来我
ReturnDistinct=DistArr
端函数

该代码利用了一个事实，即您只能向集合添加不同的值。否则它将返回一个错误

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

---

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

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

函数返回不同（InpRng）
暗淡单元格作为范围
作为整数的Dim i
Dim DistCol作为新系列
Dim DistArr（）
如果TypeName（InpRng）“Range”，则退出函数
'将所有不同的值添加到集合
对于InpRng中的每个单元
出错时继续下一步
DistCol.Add Cell.Value，CStr（Cell.Value）
错误转到0
下一个细胞
'将集合写入数组
重拨DistArr（1到DistCol.Count）
对于i=1到DistCol.Count步骤1
DistArr（i）=DistCol.项目（i）
接下来我
ReturnDistinct=DistArr
端函数

该代码利用了一个事实，即您只能向集合添加不同的值。否则它将返回一个错误

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

---

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

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

---

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

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

---

代码不执行任何操作（未执行任何操作），我在哪里可以看到结果？@TomStevens在运行此操作之前，您需要选择所有数据，然后在运行此操作之后，将只选择不同的选择。代码不执行任何操作（未执行任何操作），在哪里可以看到结果？@TomStevens在运行此操作之前，您需要选择所有数据，然后在运行此操作之后，只会选择不同的选择。使用字典优于集合。使用字典优于集合。