Excel VBA multi select drop down list

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.