如何创建多选下拉列表？

Question

我有一个包含五张纸的 Excel 文档。在第二张纸上，

Private Sub Worksheet_Change (ByVal Target As Range)

下有三个代码，如下所示：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub 'only handling one-cell changes
    
    DoMessage Target
    HideShowRows Target
    DropDown Target
    
End Sub

DoMessage Target 和 HideShowRows 很好，它们工作得很好。 DropDown 目标不起作用。该代码应该允许用户同时且不重复地选择下拉列表中的多个项目。这是这个的代码：

Sub DropDown(Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Not Intersect(Target, Range("H11")) Is Nothing Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
        GoTo Exitsub
    Else: If Target.Value = "" Then GoTo Exitsub Else
        Application.EnableEents = False
        Newvalue = Target.Value
        Application.Undo
        Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    Target.Value = Oldvalue & vbNewLine & Newvalue
            Else:
                Target.Value = Oldvalue
            End If
        End If
    End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

代码有什么问题？

Answer 1

试试这个：

Sub DropDown(Target As Range)
    Const SEP As String = vbNewLine
    Dim Oldvalue As String
    Dim Newvalue As String, arr, el, s As String, removing As Boolean
    Application.EnableEvents = True
    On Error GoTo Exitsub
    If Not Intersect(Target, Me.Range("H11")) Is Nothing Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
        Else
            Newvalue = Target.Value
            If Len(Newvalue) = 0 Then Exit Sub 'nothing to do...
            
            Application.EnableEvents = False
            Application.Undo
            Oldvalue = Target.Value
            
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                arr = Split(Oldvalue, SEP) 'split if multiple values
                For Each el In arr         'loop over previous selection(s) and compare to new value
                    If el <> Newvalue Then
                        s = s & IIf(Len(s) > 0, SEP, "") & el
                    Else
                        removing = True    'previous selection was re-selected
                    End If
                Next el
                If Not removing Then s = s & SEP & Newvalue
                Target.Value = s
            End If
        End If
    End If
    Application.EnableEvents = True
    Exit Sub
Exitsub:
    Debug.Print Err.Description
    Application.EnableEvents = True
End Sub