如何修改VBA数据验证下拉列表代码，支持自由输入且避免内容重复？

问题背景 #

现有VBA代码实现了数据验证列表的多选功能，但输入自由文本时，会触发Worksheet_Change事件，通过oldValue & DelimiterType & newValue拼接内容，导致重复（甚至按回车都会触发）。核心原因是无法区分用户是选择列表项还是手动输入文本，直接拼接新旧值造成重复。

修改后的完整代码 #

Private Sub Worksheet_Change(ByVal Destination As Range)
    Dim rngDropdown As Range
    Dim oldValue As String
    Dim newValue As String
    Dim DelimiterType As String
    Dim validationList As String
    Dim listItems As Variant
    Dim isInList As Boolean
    Dim i As Integer
    Dim arr() As String
    
    DelimiterType = vbCrLf
    If Destination.Count > 1 Then Exit Sub
    
    On Error Resume Next
    Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitError
    
    If rngDropdown Is Nothing Then GoTo exitError
    If Destination.Validation.Type <> 3 Then GoTo exitError ' 仅处理列表类型的数据验证
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    newValue = Trim(Destination.Value)
    Application.Undo
    oldValue = Trim(Destination.Value)
    Destination.Value = newValue
    
    ' 获取当前单元格的验证列表项
    validationList = Destination.Validation.Formula1
    validationList = Replace(validationList, "=", "")
    listItems = Split(validationList, ",")
    
    ' 判断新输入值是否在验证列表中
    isInList = False
    For i = LBound(listItems) To UBound(listItems)
        If Trim(listItems(i)) = newValue Then
            isInList = True
            Exit For
        End If
    Next i
    
    If oldValue <> "" And newValue <> "" Then
        ' 处理列表项的多选切换（原逻辑保留）
        If isInList Then
            arr = Split(oldValue, DelimiterType)
            ' 检查新值是否已存在
            If IsError(Application.Match(newValue, arr, 0)) Then
                Destination.Value = oldValue & DelimiterType & newValue
            Else
                ' 已存在则移除
                Destination.Value = ""
                For i = LBound(arr) To UBound(arr)
                    If Trim(arr(i)) <> newValue Then
                        Destination.Value = Destination.Value & arr(i) & DelimiterType
                    End If
                Next i
                If Destination.Value <> "" Then
                    Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
                End If
            End If
        Else
            ' 处理自由输入文本：检查是否已存在，不存在才添加
            arr = Split(oldValue, DelimiterType)
            If IsError(Application.Match(newValue, arr, 0)) Then
                Destination.Value = oldValue & DelimiterType & newValue
            Else
                ' 已存在则不修改
                Destination.Value = oldValue
            End If
        End If
    ElseIf newValue <> "" Then
        ' 首次输入，直接赋值
        Destination.Value = newValue
    End If
    
    ' 清理多余分隔符
    Destination.Value = Replace(Destination.Value, DelimiterType & DelimiterType, DelimiterType)
    If Destination.Value <> "" Then
        If Right(Destination.Value, Len(DelimiterType)) = DelimiterType Then
            Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
        End If
        If Left(Destination.Value, Len(DelimiterType)) = DelimiterType Then
            Destination.Value = Right(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
        End If
    End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
exitError:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 保留原事件（如需扩展功能可补充）
End Sub

关键修改说明 #

• 区分列表项与自由文本：读取数据验证的Formula1获取列表项，判断用户输入值是否属于预设列表
• 自由输入去重逻辑：对手动输入的文本，先拆分旧值为数组，检查新值是否已存在，仅当不存在时才添加，避免重复拼接
• 简化冗余逻辑：移除原代码中重复的分隔符处理规则，统一清理逻辑，减少出错概率
• 边界场景覆盖：处理首次输入、空值、重复输入等情况，避免无效操作触发错误

内容的提问来源于stack exchange，提问作者RonanC