Question

我当前正在使用此代码来允许用户从下拉列表中选择多种化学品。我们的代码存在的问题是，当用户要删除一个用户时，它只会删除所有用户。

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`enter code here`
       Dim Oldvalue As String
       Dim Newvalue As String
        Application.EnableEvents = True
         On Error GoTo Exitsub
           If Target.Column = 4 Or Target.Column = 10 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
        Application.EnableEvents = True
          Exitsub:
Application.EnableEvents = True
End Sub

Answer 1

我想这就是你想要做的：

Private Sub Worksheet_Change(ByVal Target As Range)
    Const SEP = "|"
    Dim Oldvalue As String, valMatch As Boolean
    Dim Newvalue As String, v, finalVal, arr, e, sp

    If Target.CountLarge > 1 Then Exit Sub 'Only operate on single-cell changes

    'find out if the Target cell has validation applied
    On Error Resume Next
    v = Target.SpecialCells(xlCellTypeAllValidation).Count
    On Error GoTo 0

    If Target.Column = 4 Or Target.Column = 10 _
        And v > 0 And Len(Target.Value) > 0 Then

        On Error GoTo haveError
        Application.EnableEvents = False
        Newvalue = Target.Value
        Application.Undo
        Oldvalue = Target.Value

        If Oldvalue = "" Then
             finalVal = Newvalue
        Else
             arr = Split(Oldvalue, "|")'get array of previous values
             For Each e In arr
                If e <> Newvalue Then
                    finalVal = finalVal & IIf(Len(finalVal) > 0, SEP, "") & e
                Else
                    valMatch = True 'selection matches a value already in the list
                                    '  so don't add it
                End If
             Next e
             If Not valMatch Then finalVal = finalVal & SEP & Newvalue
        End If
        Target.Value = finalVal
    End If

haveError:
    If Err <> 0 Then Debug.Print Err.Description
    Application.EnableEvents = True
End Sub

Excel VBA帮助_允许用户删除

1 个答案: