Multiple Items in Data Validation List

[boilermaker1997]

I found the following code on another website. It allows you to choose multiple items in a data validation list and display them in the same cell. The items are separated by commas. In addition, you can re-select an item and it will be removed from the cell.

I was wondering if someone would look at the code and tell me how to change it so the items are separated by a line break in the cell rather than commas.

Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
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
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 3 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
lUsed = InStr(1, oldVal, newVal)
If lUsed > 0 Then
If Right(oldVal, Len(newVal)) = newVal Then
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
Else
Target.Value = Replace(oldVal, newVal & ", ", "")
End If
Else
Target.Value = oldVal _
& ", " & newVal
End If

End If
End If
End If
End If

exitHandler:
Application.EnableEvents = True
End Sub

 

[Jerry Sullivan]

Hi boilermaker1997,

That's an interesting idea.

Below is some code you can try.....

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String, newVal As String
    
    On Error GoTo exitHandler
    If Target.Count > 1 Or Target.Text = "" Then Exit Sub
    
    Set rngDV = Intersect(Columns("C"), _
        Target.SpecialCells(xlCellTypeSameValidation))
    If rngDV Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    newVal = Target.Text
    Application.Undo
    oldVal = Target.Text
    Target.Value = newVal
    If oldVal = "" Then GoTo exitHandler
    
    If oldVal = newVal Then
        Target.Value = ""
    ElseIf InStr(1, oldVal, newVal) > 0 Then
        If Right(oldVal, Len(newVal)) = newVal Then
            Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)
        Else
            Target.Value = Replace(oldVal, newVal & Chr(10), "")
        End If
    Else
        Target.Value = oldVal & Chr(10) & newVal
    End If
  
exitHandler:
    Application.EnableEvents = True
End Sub

 

[boilermaker1997]

Thanks for your help. I tried your code and unless I'm doing something wrong, it doesn't appear to be doing anything. I am only able to select one item at a time from a drop down list.

 

[boilermaker1997]

Thanks for your help. I tried your code and unless I'm doing something wrong, it doesn't appear to be doing anything. I am only able to select one item at a time from a drop down list.

Disregard my last post. I found what I was doing wrong. Is there a way to may this apply to all columns in the worksheet? Again, thanks for your help.

 

[Jerry Sullivan]

Disregard my last post. I found what I was doing wrong. Is there a way to may this apply to all columns in the worksheet? Again, thanks for your help.

Just modify these lines....

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String, newVal As String
    
    On Error GoTo exitHandler
    If Target.Count > 1 Or Target.Text = "" Then Exit Sub
    
[COLOR="Blue"]    If Target.SpecialCells(xlCellTypeSameValidation) _
        Is Nothing Then Exit Sub[/COLOR]
    
    Application.EnableEvents = False
    newVal = Target.Text
    Application.Undo
    oldVal = Target.Text
    Target.Value = newVal
    If oldVal = "" Then GoTo exitHandler
    
    If oldVal = newVal Then
        Target.Value = ""
    ElseIf InStr(1, oldVal, newVal) > 0 Then
        If Right(oldVal, Len(newVal)) = newVal Then
            Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)
        Else
            Target.Value = Replace(oldVal, newVal & Chr(10), "")
        End If
    Else
        Target.Value = oldVal & Chr(10) & newVal
    End If
  
exitHandler:
    Application.EnableEvents = True
End Sub

 

[boilermaker1997]

It works perfectly! Thanks for your help.

 

[aavins73]

Just modify these lines....

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String, newVal As String
    
    On Error GoTo exitHandler
    If Target.Count > 1 Or Target.Text = "" Then Exit Sub
    
[COLOR=Blue]    If Target.SpecialCells(xlCellTypeSameValidation) _
        Is Nothing Then Exit Sub[/COLOR]
    
    Application.EnableEvents = False
    newVal = Target.Text
    Application.Undo
    oldVal = Target.Text
    Target.Value = newVal
    If oldVal = "" Then GoTo exitHandler
    
    If oldVal = newVal Then
        Target.Value = ""
    ElseIf InStr(1, oldVal, newVal) > 0 Then
        If Right(oldVal, Len(newVal)) = newVal Then
            Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)
        Else
            Target.Value = Replace(oldVal, newVal & Chr(10), "")
        End If
    Else
        Target.Value = oldVal & Chr(10) & newVal
    End If
  
exitHandler:
    Application.EnableEvents = True
End Sub

I used the above code successfully. I would like to apply multiple validation for 3 columns. i.e there are certain columns for which i would like to restrict with only one value and certain columns for which i can have multiple values.

 

[Jerry Sullivan]

Hi aavins73,

Try using this version. Modify the code in blue font to reference the range in which you want any DV cells to allow multiple items.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim oldVal As String, newVal As String

    
    On Error GoTo exitHandler

    
    '---Test to see if code should continue.
    '   Test statements could be combined, and are
    '      shown separately to simplify modification


    If Target.Count > 1 Or Target.Text = "" Then Exit Sub

    
    If Target.SpecialCells(xlCellTypeSameValidation) _
        Is Nothing Then Exit Sub

    
    '---modify to any valid range reference on activesheet
    If Intersect(Target, [COLOR="#0000CD"][B]Range("D:F")[/B][/COLOR]) _
        Is Nothing Then Exit Sub

    
    Application.EnableEvents = False
    newVal = Target.Text
    Application.Undo
    oldVal = Target.Text
    Target.Value = newVal
    If oldVal = "" Then GoTo exitHandler

    
    If oldVal = newVal Then
        Target.Value = ""
    ElseIf InStr(1, oldVal, newVal) > 0 Then
        If Right(oldVal, Len(newVal)) = newVal Then
            Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)
        Else
            Target.Value = Replace(oldVal, newVal & Chr(10), "")
        End If
    Else
        Target.Value = oldVal & Chr(10) & newVal
    End If

  
exitHandler:
    Application.EnableEvents = True
End Sub

 

[aavins73]

Thanks, its working fine.

 

[kjsab]

Hello everyone...hoping you can help.

I am truly a VB novice, but was using this same code in Excel 2010 a couple of weeks ago. I originally had it working fine in a test workbook, but had to disable the macros in order to post it on an internal, company forum. Now that I have re-enabled the macros, and re-pasted the code, it does not run at all. However, if I start with a blank workbook, I am able to copy the code and it works fine.

My existing workbook has 20 columns with data validation (I only want to allow multiple values in 3 of them), so I don't want to re-create the entire workbook from scratch. Any ideas on what might be preventing the original, working code from running??

Many thanks in advance.