VBA to deselect a single value in a multi-selection drop down list.

[dsharae57]

I have a VBA script that allows me to select multiple values from a drop-down list in the cell but will not allow me to deselect a single value. For Example, I have selected 5 names from a drop town list but the 3rd name on the list I selected by mistake. I want to be able to de-select that 3rd name without having to delete everything and start my selections completely over. This is the VBA that I currently have:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Address = "$E$26" 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 & vbNewLine & Newvalue
        Else:
          Target.Value = Oldvalue
        End If
      End If
    End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

 

[smozgur]

Welcome to the MrExcel Message Board!

I wouldn't use the Instr function, instead, the code below is using an array to make sure that it doesn't remove "Yellow Onion" when I want to remove "Onion" only.
I assume you want to deselect the accidentally selected item on the next click on the item.

The code is not more complicated even it looks like having more lines. Please let us know if something doesn't make sense.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Dim oldArr As Variant
Dim lastIndex As Integer
Dim i As Integer
Dim j As Integer
On Error GoTo errHandler
If Target.Address = "$E$26" Then
    If Not Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
        If Target.Value <> "" Then
            Application.EnableEvents = False
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = Newvalue Then
                Target.Value = ""
                GoTo exitSub
            End If
            oldArr = Split(Oldvalue, vbNewLine)
            lastIndex = UBound(oldArr)
            For i = 0 To lastIndex
                If oldArr(i) = Newvalue Then
                    For j = i To lastIndex - 1
                        oldArr(j) = oldArr(j + 1)
                    Next j
                    ReDim Preserve oldArr(lastIndex - 1)
                    GoTo generateNewValue
                End If
            Next i
            ReDim Preserve oldArr(lastIndex + 1)
            oldArr(lastIndex + 1) = Newvalue
generateNewValue:
            Target.Value = Join(oldArr, vbNewLine)
        End If
    End If
End If
errHandler:
If Err Then
    MsgBox Err.Description
End If
exitSub:
Application.EnableEvents = True
End Sub