在Excel中为数据验证字段选择多个项目

Question

我在工作表上有多个下拉列表，有时需要个人在验证字段中输入多个选择。换句话说，有时他们需要的不仅仅是苹果，他们还需要橙子;那么数据验证字段将是苹果/橙子。

这段代码一直工作到最近，现在由于某种原因它不起作用，代码在“SHEET”中而不是在模块中，以便它在该表中专门工作。

以下是可能影响它的工作表上的规格：宏被锁定（我试图让它解锁并且没有修复它）。在同一工作簿中有两个具有相似代码的工作表（我尝试从另一个工作表中删除该脚本，但它没有修复它）。还有一个问题与此非常接近，但没有答案，所以希望“知道”这段代码有效，但现在也许没有人可以为我查看。

Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 2 And Target.Row > 11 And Target.Row < 27 Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
        GoTo Exitsub
    Else: If Target.Value = "" Then GoTo Exitsub Else
        Application.EnableEvents = 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 & "/" & Newvalue
            Else:
                Target.Value = Oldvalue
            End If
        End If
    End If
End If

Answer 1

我认为您的问题在于禁用和启用事件。 我重构了你的代码，它工作正常。见下文：

Private Sub Worksheet_Change(ByVal Target As Range)
'Original Code by Sumit Bansal from https://trumpexcel.com
'To Select Multiple Items from a Drop Down List in Excel

'Refactored error handling...
    On Error GoTo halt
    Dim Oldvalue As String, Newvalue As String
    Application.EnableEvents = False '/* disable events here */
    If Target.Column = 2 And Target.Row >= 11 And Target.Row <= 27 Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            'GoTo ExitSub 
        Else
            If Target.Value = "" Then GoTo ExitSub
            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 & "/" & Newvalue
                Else
                    Target.Value = Oldvalue
                End If
            End If
        End If
    End If

ExitSub:
    Application.EnableEvents = True '/* enable before exit */
    Exit Sub
halt:
    '/* handle error and communicate to user */
    MsgBox "Opps, encountered error but dismissed it. See details below:" & _
    vbNewLine & Err.Number & ": " & Err.Description
    Err.Clear '/* clear the error */ 
    Resume ExitSub '/* make sure to re-enable events */
End Sub

我还删除了不相关的代码。 HTH。