Unable to remove drop down selection values from a cell

[S0ph1e]

Hi!

I have used the below VBA code so i can make multiple sections within a cell from a drop down list. This was all working fine and i could easily delete any section i made, but now i can't. When i select an option and then try and delete it form the cell by pressing delete or backspace, it doesn't remove it. Does anyone know why? Not sure if i need to change the code or not...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Not Intersect(Target, Range("N:N,M:M")) Is Nothing 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

 

[RoryA]

You could use something like this, which will allow you to delete an item by just selecting it again from the validation list:

Private Sub Worksheet_Change(ByVal Target As Range)
   Const SEPARATOR As String = ", "
   Dim Oldvalue As String
   Dim Newvalue As String
   On Error GoTo Exitsub
   If Not Intersect(Target, Range("N:N,M:M")) Is Nothing 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 = "" Then
               Target.Value = Newvalue
            Else
               If InStr(1, Oldvalue, Newvalue) = 0 Then
                  Target.Value = Oldvalue & SEPARATOR & Newvalue
               Else
                  Dim parts() As String
                  parts = Split(Oldvalue, SEPARATOR)
                  Dim n As Long
                  For n = LBound(parts) To UBound(parts)
                     If parts(n) = Newvalue Then
                        parts(n) = "|#|"
                        Exit For
                     End If
                  Next n
                  Target.Value = Join(Filter(parts, "|#|", False), SEPARATOR)
               End If
            End If
         End If
      End If
   End If
Exitsub:
   Application.EnableEvents = True
End Sub

 

[S0ph1e]

Thank you that's worked great

 

[RoryA]

Glad we could help.

 

[S0ph1e]

Glad we could help.

Sorry to come back to this issue, but I've just opened up the spread sheet and for some reason I can no longer add multiple selections to the cell, and it no longer deletes the value when I select it again! I did make a slight change to the code to prevent an error message when adding a new row, but I did a check after changing it and it still worked perfectly fine up until now! Do you have any idea what the issue might be? Below is the full code within Sheet 1 of my VBA.

Private Sub Worksheet_Change(ByVal Target As Range)
   Const SEPARATOR As String = ", "
   Dim Oldvalue As String
   Dim Newvalue As String
   On Error GoTo Exitsub
   If Not Intersect(Target, Range("N:N,M:M")) Is Nothing Then
      If Not Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
          If Target.CountLarge > 1 Then Exit Sub
            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 & SEPARATOR & Newvalue
               Else
                  Dim parts() As String
                  parts = Split(Oldvalue, SEPARATOR)
                  Dim n As Long
                  For n = LBound(parts) To UBound(parts)
                     If parts(n) = Newvalue Then
                        parts(n) = "|#|"
                        Exit For
                     End If
                  Next n
                  Target.Value = Join(Filter(parts, "|#|", False), SEPARATOR)
               End If
            End If
         End If
      End If
Exitsub:
   Application.EnableEvents = True



Dim myTableRange As Range
Dim myUpdateRange As Range

Set myTableRange = Range("A4:AD1000")

If Intersect(Target, myTableRange) Is Nothing Then Exit Sub

Set myUpdateRange = Range("AE" & Target.Row)

myUpdateRange.Value = Now



End Sub

 

[RoryA]

Try changing it to:

Private Sub Worksheet_Change(ByVal Target As Range)
   Const SEPARATOR As String = ", "
   Dim Oldvalue As String
   Dim Newvalue As String
   On Error GoTo Exitsub
   If Not Intersect(Target, Range("N:N,M:M")) Is Nothing Then
      If Not Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
          If Target.CountLarge > 1 Then Exit Sub
            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 & SEPARATOR & Newvalue
               Else
                  Dim parts() As String
                  parts = Split(Oldvalue, SEPARATOR)
                  Dim n As Long
                  For n = LBound(parts) To UBound(parts)
                     If parts(n) = Newvalue Then
                        parts(n) = "|#|"
                        Exit For
                     End If
                  Next n
                  Target.Value = Join(Filter(parts, "|#|", False), SEPARATOR)
               End If
            End If
         End If
      End If



Dim myTableRange As Range
Set myTableRange = Range("A4:AD1000")

If Not Intersect(Target, myTableRange) Is Nothing Then Range("AE" & Target.Row).Value = Now

Exitsub:
   Application.EnableEvents = True


End Sub

 

[S0ph1e]

Try changing it to:

Private Sub Worksheet_Change(ByVal Target As Range)
   Const SEPARATOR As String = ", "
   Dim Oldvalue As String
   Dim Newvalue As String
   On Error GoTo Exitsub
   If Not Intersect(Target, Range("N:N,M:M")) Is Nothing Then
      If Not Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
          If Target.CountLarge > 1 Then Exit Sub
            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 & SEPARATOR & Newvalue
               Else
                  Dim parts() As String
                  parts = Split(Oldvalue, SEPARATOR)
                  Dim n As Long
                  For n = LBound(parts) To UBound(parts)
                     If parts(n) = Newvalue Then
                        parts(n) = "|#|"
                        Exit For
                     End If
                  Next n
                  Target.Value = Join(Filter(parts, "|#|", False), SEPARATOR)
               End If
            End If
         End If
      End If



Dim myTableRange As Range
Set myTableRange = Range("A4:AD1000")

If Not Intersect(Target, myTableRange) Is Nothing Then Range("AE" & Target.Row).Value = Now

Exitsub:
   Application.EnableEvents = True


End Sub

That's worked. A little confused why it didn't stop working when I made the changes.. So i need to make sure the 'Exitsub:
Application.EnableEvents = True' is at the end just before the end sub... Thank you