Excel数据验证实现同一单元格多选逗号分隔的VBA优化求助

需求说明 #

需要为配置了列表类数据验证的Excel单元格实现多选功能，要求：

• 多个选中值用, （逗号加空格）分隔，无重复值
• 可选值列表：Mango、Iphone、Pixel、Apple
• 选中多个值后输出示例：Apple, Mango, Pixel

原代码存在的问题 #

原有VBA代码可以实现基础多选，但有两个明显缺陷：

1. 多选后内容末尾会多出多余逗号，例如输出为Apple, Mango, Pixel,
2. 无法直接删除单个选中值或者清空单元格，必须执行全部清除操作才能重新选值

优化后VBA代码 #

直接替换原有工作表的Change事件代码即可：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRgVal As Range
    Dim xStrNew As String
    Dim xStrOld As String
    Dim xArr As Variant
    Dim i As Integer
    Dim xExists As Boolean
    
    On Error Resume Next
    Set xRgVal = Cells.SpecialCells(xlCellTypeAllValidation)
    ' 选中多个单元格、无数据验证区域、当前单元格不在数据验证范围内都直接退出
    If (Target.Count > 1) Or (xRgVal Is Nothing) Or Intersect(Target, xRgVal) Is Nothing Then
        Exit Sub
    End If
    
    Application.EnableEvents = False
    xStrNew = Trim(Target.Value)
    ' 处理清空操作：如果新值为空直接清空单元格
    If xStrNew = "" Then
        Target.Value = ""
        Application.EnableEvents = True
        Exit Sub
    End If
    
    ' 撤销本次输入，拿到旧值
    Application.Undo
    xStrOld = Trim(Target.Value)
    
    ' 旧值为空直接赋值新值
    If xStrOld = "" Then
        Target.Value = xStrNew
        Application.EnableEvents = True
        Exit Sub
    End If
    
    ' 拆分旧值为数组，判断新值是否已存在，避免子字符串误判
    xArr = Split(xStrOld, ", ")
    xExists = False
    For i = LBound(xArr) To UBound(xArr)
        If Trim(xArr(i)) = xStrNew Then
            xExists = True
            Exit For
        End If
    Next
    
    ' 不存在就拼接，存在就保留原有值
    If Not xExists Then
        Target.Value = xStrOld & ", " & xStrNew
    Else
        Target.Value = xStrOld
    End If
    
    Application.EnableEvents = True
End Sub

操作步骤 #

1. 配置阶段：按Alt+F11调出VBA编辑器，在左侧工程栏双击要实现多选的工作表，粘贴上述代码后关闭编辑器，将文件保存为*.xlsm（启用宏的工作簿）格式，再给目标单元格正常配置列表类数据验证，来源填写Mango,Iphone,Pixel,Apple即可
2. 使用阶段：

• 下拉选择对应值会自动追加到单元格，重复选择不会重复添加
• 要删除单个值：双击单元格删除对应内容和多余的逗号即可
• 要清空所有值：选中单元格按Delete键直接清空，可正常重新选择内容

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