Question

我的工作簿中有一个页面，其中某些单元格是多选的。用户可以从下拉列表中选择值，它会将它们附加并格式化以上传到我们的系统中。它运作得很好 - 但只有一个问题。目前无法删除单个值。如果用户从下拉列表中选择了错误的值，则他们必须删除并重新开始。有没有办法删除个别值？这是当前的多选代码：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strSep As String
Dim strSep2 As String
Dim header As String
Dim MatchField As Range
Dim AnsType As Range

Application.ScreenUpdating = False

strSep = Chr(34) & "," & Chr(34)
strSep2 = "," & Chr(34)

header = Me.Cells(11, Target.Column).Value 
Set MatchField = ThisWorkbook.Worksheets("User Fields").Range("B16:B100").Find(header) 

If Not MatchField Is Nothing Then
    Set AnsType = MatchField.Offset(0, 2) 
End If

Application.EnableEvents = False
On Error Resume Next

If Target.Count > 1 Then GoTo exitHandler 

Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then 
   'do nothing
Else 'cell has data validation
    If InStr(1, AnsType, "Multiple") > 0 Then 'Determines if current column corresponds to a multi-select field

    newVal = Target.Value 
    Application.Undo 
    oldVal = Target.Value 
    Target.Value = newVal 

    If newVal = "" Then
        'do nothing
    Else 
        If oldVal = "" Then 
            Target.Value = newVal 
        ElseIf InStr(1, oldVal, newVal) = 0 Then 
            If InStr(1, oldVal, Chr(34)) > 0 Then 
                Target.Value = oldVal & strSep2 & newVal & Chr(34) 
            Else 
                Target.Value = Chr(34) & oldVal & strSep & newVal & Chr(34) 
            End If
        Else
            Target.Value = oldVal
        End If
    End If
  End If
End If
Application.ScreenUpdating = True
exitHandler:
  Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Answer 1

您需要删除禁止同一项目的双精度才能从字符串中删除它的“If”语句。请尝试以下代码，将双打语句注释掉。

Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated: 2016/4/12
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If Not Application.Intersect(Target, xRng) Is Nothing Then
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 <> "" Then
            If xValue2 <> "" Then
'                If xValue1 = xValue2 Or _
'                   InStr(1, xValue1, ", " & xValue2) Or _
                   InStr(1, xValue1, xValue2 & ",") Then
                If InStr(1, xValue1, xValue2 & ",") > 0 Then
                    xValue1 = Replace(xValue1, xValue2 & ", ", "") ' If it's in the middle with comma
                    Target.Value = xValue1
                    GoTo jumpOut
                End If
                If InStr(1, xValue1, ", " & xValue2) > 0 Then
                    xValue1 = Replace(xValue1, ", " & xValue2, "") ' If it's at the end with a comma in front of it
                    Target.Value = xValue1
                    GoTo jumpOut
                End If
                If xValue1 = xValue2 Then ' If it is the only item in string
                    xValue1 = ""
                    Target.Value = xValue1
                    GoTo jumpOut
                End If
                Target.Value = xValue1 & ", " & xValue2
            End If
jumpOut:
        End If
    End If
    Application.EnableEvents = True
End Sub

Answer 2

我对约翰的回答有一些疑问，像“ 707”和“ 7”这样的值会引起问题。这是我最终使用的脚本。请注意，第一部分的实现也有所不同。

Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To allow multiple selections in a Drop Down List in Excel (without repetition)
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 9 Then
    If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
        GoTo Exitsub
    ElseIf Target.Value = "" Then
        GoTo Exitsub
    Else
        Application.EnableEvents = False
        Newvalue = Target.Value
        Application.Undo
        Oldvalue = Target.Value
        Target.Value = Newvalue
       If Oldvalue <> "" Then
            If Newvalue <> "" Then
                If InStr(1, Oldvalue, ", " & Newvalue & ",") > 0 Then
                    Oldvalue = Replace(Oldvalue, Newvalue & ", ", "") ' If it's in the middle with comma
                    Target.Value = Oldvalue
                    GoTo jumpOut
                End If
                If Left(Oldvalue, Len(Newvalue & ", ")) = Newvalue & ", " Then
                    Oldvalue = Replace(Oldvalue, Newvalue & ", ", "") ' If it's at the start with comma
                    Target.Value = Oldvalue
                    GoTo jumpOut
                End If
                If Right(Oldvalue, Len(", " & Newvalue)) = ", " & Newvalue Then
                    Oldvalue = Left(Oldvalue, Len(Oldvalue) - Len(", " & Newvalue)) ' If it's at the end with a comma in front of it
                    Target.Value = Oldvalue
                    GoTo jumpOut
                End If
                If Oldvalue = Newvalue Then ' If it is the only item in string
                    Oldvalue = ""
                    Target.Value = Oldvalue
                    GoTo jumpOut
                End If
                Target.Value = Oldvalue & ", " & Newvalue
            End If
jumpOut:
        End If
    End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

VBA：从多选字段中删除值

2 个答案: