excelvba

Excel VBA multi select drop down list


I am trying to create a multi select dropdown list with Excel VBA. I have the following code for Sheet1.

With Range("B27").Validation
    .Delete
End With

With Range("B27")
    .Value = "[Select from drop down]"
End With

With Range("B27").Validation
     .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop,Formula1:="=DropDownList_data!D1:D3")
     .IgnoreBlank = True
End With

Cells D1, D2 and D3 in the DropDownList_data tab contain the text Item1,Item2,Item3 respectively. I have made this a multi select list by writing code in the Worksheet_Change event. When I select the 3 items consecutively, Item1,Item2,Item3 appears in Cell B27. However, when I manually delete ,Item3 from the cell the following error appears. "This value doesn't match the data validation restrictions defined for this cell."

The following is the code in the Worksheet_Change event.

Dim Newvalue, Oldvalue As String


    On Error GoTo Exitsub

    Application.EnableEvents = False


   If Target.Address="$B$27" Then
        If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
            GoTo Exitsub
            Else: If Target.Value = "" Then GoTo Exitsub Else
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Or Oldvalue = "[Select from drop down]" Then
                Target.Value = Newvalue
            Else
                Dim strArray() As String
                strArray = Split(Oldvalue, ",")
                If IsInArray(Newvalue, strArray) Then
                    Target.Value = Oldvalue
                Else
                    Target.Value = Oldvalue & "," & Newvalue
                End If
            End If
        End If
    End If
Exitsub:
    Application.EnableEvents = True

How can I manually delete an item after I have selected it?


Solution

  • The trick when doing this type of thing is you can't manually edit the cell content and try to remove part of the list of selections, unless you're leaving an empty cell or a single value from the list.

    The typical approach to remove a value you already selected is to select it again from the list and have the event handler remove it from the list in the cell.

    Private Sub Worksheet_Change(ByVal Target As Range)
    
        ' To allow multiple selections in a Drop Down List
        Dim Oldvalue As String
        Dim Newvalue As String
        Dim rng As Range, srcRange As Range, arr, listVals
        
        'run some checks
        Set rng = Application.Intersect(Target, Me.Range("B27"))
        If rng Is Nothing Then Exit Sub
        
        Newvalue = rng.Value
        If Len(Newvalue) = 0 Then Exit Sub
        
        If rng.Value <> "" Then
            On Error GoTo Exitsub
            Application.EnableEvents = False
            Application.Undo
            Oldvalue = rng.Value
            If Oldvalue = "" Then
                rng.Value = Newvalue
            Else
                listVals = Application.Evaluate(rng.Validation.Formula1).Value
                rng.Value = SortItOut(listVals, Oldvalue, Newvalue) '<< call function
            End If
        End If
        
    Exitsub:
        If Err.Number > 0 Then Debug.Print Err.Description
        Application.EnableEvents = True
    End Sub
    
    Private Function SortItOut(listVals, oldVal, newVal)
        Const LIST_SEP As String = ", "
        Dim i As Long, arr, s, sep, t, listed, removeNewVal
        s = ""
        sep = ""
        arr = Split(oldVal, LIST_SEP)
        'new value already listed?
        removeNewVal = Not IsError(Application.Match(newVal, arr, 0))
        
        For i = 1 To UBound(listVals, 1)
            t = listVals(i, 1)
            listed = Not IsError(Application.Match(t, arr, 0))
            If listed Or newVal = t Then
                If Not (removeNewVal And newVal = t) Then
                    s = s & sep & t
                    sep = LIST_SEP
                End If
            End If
        Next i
        
        SortItOut = s
    End Function
    

    EDIT Oct 2024: a cleaner version which allows you to set an option to replace the last list separator with " and ":

    Private Sub Worksheet_Change(ByVal Target As Range)
        Const USE_AND As Boolean = True
        Const SEP As String = ", "
        Const V_AND As String = " and "
        Dim c As Range, NewValue, OldValue, arr, v, lst, removed As Boolean, pos As Long
        
        On Error GoTo Exitsub
        
        If Target.CountLarge > 1 Then Exit Sub '<< only handling single-cell changes
        
        'is the changed cell in our monitored range?
        Set c = Application.Intersect(Target, Me.Range("B5,B7,B9,B11")) ' for example
        
        If Not c Is Nothing Then
            If Len(c.Value) > 0 And Not c.Validation Is Nothing Then
            
                Application.EnableEvents = False
                NewValue = c.Value
                Application.Undo
                OldValue = c.Value
                If USE_AND Then OldValue = Replace(OldValue, V_AND, SEP) 'replace any V_AND with SEP
                
                If OldValue = "" Then
                    c.Value = NewValue  'cell was previously empty, so just keep the new value
                Else
                    arr = Split(OldValue, SEP) 'array of previous selections
                    'loop over list, flagging if `NewValue` was previously chosen
                    For Each v In arr
                        If v = NewValue Then
                            removed = True 'value was re-selected, so do not add it
                        Else
                            lst = lst & IIf(lst = "", "", SEP) & v
                        End If
                    Next v
                    'add the new value if we didn't just remove it
                    If Not removed Then lst = lst & IIf(lst = "", "", SEP) & NewValue
                    
                    If USE_AND Then 'replace SEP with V_AND between last 2 items ?
                        lst = Replace(StrReverse(lst), StrReverse(SEP), StrReverse(V_AND), 1, 1) 'limit to 1 replacement
                        lst = StrReverse(lst)
                    End If
                    c.Value = lst
                End If
            End If    'has validation and non-empty
        End If        'handling this cell
        
    Exitsub:
        If Err.Number <> 0 Then MsgBox Err.Description
        Application.EnableEvents = True
    End Sub
    

    Note that SEP and V_AND can't be part of any of the validation list items.