Search code examples
excelvbadropdown

Excel - Multiple selection drop down list - no duplication of selection


I have developed on my excel spreadsheet that multiple items can be selected in a drop down list using the following code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler

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

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then

Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
    If oldVal = "" Then

      Else
      If newVal = "" Then

      Else
      Target.Value = oldVal _
        & ", " & newVal

      End If
    End If
End If


exitHandler:
  Application.EnableEvents = True
End Sub

But, I want to now validate the answers that the drop down list items can only be selected once. And preferably, if the user selects that item again, that is it then removed.

Any help would be greatly appreciated.


Solution

  • Try this:

    Private Sub Worksheet_Change(ByVal Target As Range)
        Const SEP As String = ", "
        Dim rngDV As Range
        Dim oldVal As String
        Dim newVal As String
        Dim arr, m, v
        If Target.Count > 1 Then GoTo exitHandler
    
        On Error Resume Next
        Set rngDV = Target.SpecialCells(xlCellTypeSameValidation)
        On Error GoTo exitHandler
        If rngDV Is Nothing Then Exit Sub
        
        newVal = Target.Value
        If Len(newVal) = 0 Then Exit Sub 'user has cleared the cell...
        
        Application.EnableEvents = False
        
        Application.Undo
        oldVal = Target.Value
        
        If oldVal <> "" Then
            arr = Split(oldVal, SEP)
            m = Application.Match(newVal, arr, 0)
            If IsError(m) Then
                newVal = oldVal & SEP & newVal
            Else
                arr(m - 1) = ""
                newVal = ""
                For Each v In arr
                    If Len(v) > 0 Then newVal = newVal & IIf(Len(newVal) > 0, SEP, "") & v
                Next v
            End If
            Target.Value = newVal
        Else
            Target.Value = newVal 'EDIT
        End If
    
    exitHandler:
          Application.EnableEvents = True
    End Sub