Excel VBA 多选下拉列表

Question

我正在尝试使用 Excel VBA 创建一个多选下拉列表。我有 Sheet1 的以下代码。

With Range("B27").Validation
    .Delete
End With

With Range("B27")
    .Value = "[Select from drop down]"
End With

With Range("B27").Validation
     .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop,Formula1:="=DropDownList_data!D1:D3")
     .IgnoreBlank = True
End With

DropDownList_data 选项卡中的单元格 D1、D2 和 D3 分别包含文本 Item1、Item2、Item3。通过在 Worksheet_Change 事件中编写代码，我已将其设为多选列表。当我连续选择 3 个项目时，Item1、Item2、Item3 出现在单元格 B27 中。但是，当我从单元格中手动删除 ,Item3 时，会出现以下错误。 “此值与为此单元格定义的数据验证限制不匹配。”

以下是 Worksheet_Change 事件中的代码。

Dim Newvalue, Oldvalue As String


    On Error GoTo Exitsub

    Application.EnableEvents = False


   If Target.Address="$B$27" Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
            Else: If Target.Value = "" Then GoTo Exitsub Else
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Or Oldvalue = "[Select from drop down]" Then
                Target.Value = Newvalue
            Else
                Dim strArray() As String
                strArray = Split(Oldvalue, ",")
                If IsInArray(Newvalue, strArray) Then
                    Target.Value = Oldvalue
                Else
                    Target.Value = Oldvalue & "," & Newvalue
                End If
            End If
        End If
    End If
Exitsub:
    Application.EnableEvents = True

选择后如何手动删除项目？

Answer 1

执行此类操作的技巧是您不能手动编辑单元格内容并尝试删除部分选择列表，除非您从列表中留下一个空单元格或单个值。

删除您已选择的值的典型方法是从列表中再次选择它，然后让事件处理程序将其从单元格中的列表中删除。

Private Sub Worksheet_Change(ByVal Target As Range)

    ' To allow multiple selections in a Drop Down List
    Dim Oldvalue As String
    Dim Newvalue As String
    Dim rng As Range, srcRange As Range, arr, listVals
    
    'run some checks
    Set rng = Application.Intersect(Target, Me.Range("B27"))
    If rng Is Nothing Then Exit Sub
    
    Newvalue = rng.Value
    If Len(Newvalue) = 0 Then Exit Sub
    
    If rng.Value <> "" Then
        On Error GoTo Exitsub
        Application.EnableEvents = False
        Application.Undo
        Oldvalue = rng.Value
        If Oldvalue = "" Then
            rng.Value = Newvalue
        Else
            listVals = Application.Evaluate(rng.Validation.Formula1).Value
            rng.Value = SortItOut(listVals, Oldvalue, Newvalue) '<< call function
        End If
    End If
    
Exitsub:
    If Err.Number > 0 Then Debug.Print Err.Description
    Application.EnableEvents = True
End Sub

Private Function SortItOut(listVals, oldVal, newVal)
    Const LIST_SEP As String = ", "
    Dim i As Long, arr, s, sep, t, listed, removeNewVal
    s = ""
    sep = ""
    arr = Split(oldVal, LIST_SEP)
    'new value already listed?
    removeNewVal = Not IsError(Application.Match(newVal, arr, 0))
    
    For i = 1 To UBound(listVals, 1)
        t = listVals(i, 1)
        listed = Not IsError(Application.Match(t, arr, 0))
        If listed Or newVal = t Then
            If Not (removeNewVal And newVal = t) Then
                s = s & sep & t
                sep = LIST_SEP
            End If
        End If
    Next i
    
    SortItOut = s
End Function