如何去除UserForm ListBox中数据验证返回的重复值？

问题说明 #

我有一个带搜索TextBox的UserForm，仅对设置了数据验证的单元格生效。当前ListBox会返回该单元格数据验证的全部选项，但存在重复值（截图显示ListBox中出现多条重复的选项内容）。

原代码如下：

Sub Refresh_List()

Dim arr() As String
Dim rng As Range
Dim cel As Range
Dim dict

Dim i As Integer
Set dict = CreateObject("Scripting.Dictionary")
Me.ListBox1.Clear

If Is_validation(ActiveCell) Then

    If Validate_Range(ActiveCell.Validation.Formula1) Then
       Set rng = Range(ActiveCell.Validation.Formula1)
       
       For Each cel In rng
            If Me.TextBox1.Value = "" Then
                Me.ListBox1.AddItem cel.Value
            Else
                If VBA.InStr(UCase(cel.Value), UCase(Me.TextBox1.Value)) > 0 Then
                    Me.ListBox1.AddItem cel.Value
                End If
            End If
       Next
    Else
    
    arr() = VBA.Split(ActiveCell.Validation.Formula1, ",")
        For i = LBound(arr) To UBound(arr)
            If Me.TextBox1.Value = "" Then
                Me.ListBox1.AddItem arr(i)
            Else
                If VBA.InStr(UCase(arr(i)), UCase(Me.TextBox1.Value)) > 0 Then
                    Me.ListBox1.AddItem arr(i)
                End If
            End If
        Next i
    End If

End If


On Error Resume Next
Me.ListBox1.ListIndex = 0
End Sub

解决方案 #

利用Scripting.Dictionary的键唯一性特性实现去重，修改后的代码如下：

Sub Refresh_List()

Dim arr() As String
Dim rng As Range
Dim cel As Range
Dim dict
Dim i As Integer

Set dict = CreateObject("Scripting.Dictionary")
Me.ListBox1.Clear

' 忽略键的大小写差异（如需区分大小写可删除此行）
dict.CompareMode = vbTextCompare

If Is_validation(ActiveCell) Then
    If Validate_Range(ActiveCell.Validation.Formula1) Then
        Set rng = Range(ActiveCell.Validation.Formula1)
        
        For Each cel In rng
            ' 跳过空单元格
            If Trim(cel.Value) <> "" Then
                If Me.TextBox1.Value = "" Then
                    ' 将值作为字典键添加（自动去重）
                    dict(cel.Value) = ""
                Else
                    If VBA.InStr(UCase(cel.Value), UCase(Me.TextBox1.Value)) > 0 Then
                        dict(cel.Value) = ""
                    End If
                End If
            End If
        Next
    Else
        arr() = VBA.Split(ActiveCell.Validation.Formula1, ",")
        For i = LBound(arr) To UBound(arr)
            ' 跳过空项
            If Trim(arr(i)) <> "" Then
                If Me.TextBox1.Value = "" Then
                    dict(arr(i)) = ""
                Else
                    If VBA.InStr(UCase(arr(i)), UCase(Me.TextBox1.Value)) > 0 Then
                        dict(arr(i)) = ""
                    End If
                End If
            End If
        Next i
    End If
    
    ' 将字典的唯一键批量添加到ListBox
    If dict.Count > 0 Then
        Me.ListBox1.List = dict.Keys
    End If
End If

On Error Resume Next
Me.ListBox1.ListIndex = 0
End Sub

关键修改点 #

1. 启用字典的CompareMode = vbTextCompare，自动忽略大小写差异导致的“假重复”（如"Apple"和"apple"），不需要可删除
2. 遍历数据时先存入字典，利用字典键的唯一性自动过滤重复值，而非直接添加到ListBox
3. 遍历完成后，将字典的Keys转为数组批量添加到ListBox，提升效率
4. 增加空值/空项过滤，避免ListBox出现空白选项

内容的提问来源于stack exchange，提问作者Ahmed Mohammed edrees