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 kjsab,

There are many possible ways that could occur.

To narrow down the hunt, start by testing to see if the worksheet change is triggering when you click on your DV cell.

Add a call to a Msgbox like this then change one of your DV cells and see if the message pops up.

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

    Msgbox "Triggered Worksheet_Change event"

 

[Marcelo Branco]

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

Hi Jerry,

Nice code. I like it!

Just a suggestion:
Maybe you can substitute this code line
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)
by
Target.Value = Replace(oldVal, Chr(10) & newVal, "")

So, I think, the If Right(....) part would be easier to understand

If Right(oldVal, Len(newVal)) = newVal Then
    Target.Value = Replace(oldVal, Chr(10) & newVal, "")
Else
    Target.Value = Replace(oldVal, newVal & Chr(10), "")
End If

M.

 

[Jerry Sullivan]

Hi Marcelo,

You're right that it would be clearer to use the same string manipulation in both cases.

In revisiting this code, I notice that it didn't account for the scenario that some of the items on the DV list could be partial matches for other items.
For example: oldVal= "shop"& Chr(10) & "cart", newVal = "art".
In those scenarios, all code above could fall down.

One way to address that would be to do the matching with delimiters before and after the New text value.

Here's a modified version that attempts to do that (and uses Replace consistently as you suggested).

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sOld As String, sNew As String
    Dim sCrOldCr As String, sCrNewCr 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, Range("D:F")) _
        Is Nothing Then Exit Sub

    Application.EnableEvents = False
    sNew = Target.Text
    Application.Undo
    sOld = Target.Text
    Target.Value = sNew
    If sOld = "" Then GoTo exitHandler
    
    '--wrap in delimiters to avoid partial match
    sCrNewCr = Chr(10) & sNew & Chr(10)
    sCrOldCr = Chr(10) & sOld & Chr(10)
    
    Select Case InStr(1, sCrOldCr, sCrNewCr)
        Case 0 '--no match
            Target = sOld & Chr(10) & sNew
        Case 1 '--match with first item
            Target = IIf(sOld = sNew, "", _
                Replace(Chr(10) & sOld, sCrNewCr, ""))
        Case Len(sOld) - Len(sNew) + 1 '--match with last item
            Target = Replace(sOld & Chr(10), sCrNewCr, "")
        Case Else  '--match with one middle item
            Target = Replace(sOld, sCrNewCr, Chr(10))
    End Select

exitHandler:
    Application.EnableEvents = True
End Sub

 

[Marcelo Branco]

In revisiting this code, I notice that it didn't account for the scenario that some of the items on the DV list could be partial matches for other items.
For example: oldVal= "shop"& Chr(10) & "cart", newVal = "art".

Good catch!

This is my revised code. (see the code line in red)
I'm using ", " (comma+space) as separator

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 [COLOR=#ff0000]InStr(1, ", " & oldVal, ", " & newVal) > 0 [/COLOR]Then
        If Right(oldVal, Len(newVal)) = newVal Then
            Target.Value = Replace(oldVal, ", " & newVal, "")
        Else
            Target.Value = Replace(oldVal, newVal & ", ", "")
        End If
    Else
        Target.Value = oldVal & ", " & newVal
    End If
  
exitHandler:
    Application.EnableEvents = True
End Sub

DV in C2
List in F1:F4

It seems that it's working fine

	C​	D​	E​	F​
1​	Type​			shop​
2​	shop, cart, art​			cart​
3​				art​
4​				dart​

<TBODY>
</TBODY>

M.

 

[Marcelo Branco]

I'm wrong, my code has problems. Revising...

M.

 

[DCMINICAN]

Hey guys,

Thanks for the tips and tricks! This code is awesome.

I have a question, this code seems to affect all data validation columns or rows on a worksheet. Is there a way to modify this code so that it only affects one specific column or row?

I have multiple DV Columns, but I'm only interested in a specific column having the multiple selection feature. I'd like to keep the others with the standard method.

Any thoughts?

 

[Marcelo Branco]

Hey guys,

Thanks for the tips and tricks! This code is awesome.

I have a question, this code seems to affect all data validation columns or rows on a worksheet. Is there a way to modify this code so that it only affects one specific column or row?

I have multiple DV Columns, but I'm only interested in a specific column having the multiple selection feature. I'd like to keep the others with the standard method.

Any thoughts?

As Jerry is offline I'll try to help

Observe his code in #13. You have to adapt this part, more specifically the text in red, adjusting to your range of interest.

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

M.

 

[DCMINICAN]

As Jerry is offline I'll try to help

Observe his code in #13. You have to adapt this part, more specifically the text in red, adjusting to your range of interest.

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

M.

Marcelo thanks for the quick turnaround. Got it! Thanks!

 

[Marcelo Branco]

Marcelo thanks for the quick turnaround. Got it! Thanks!

You are welcome.

BTW, Jerry is the one who deserves the thanks for the great code.

M.

 

[DCMINICAN]

Hey guys,

I'm back! LOL.

So I have been using this code in my spreadsheet successfully for a few months now. However, I've encountered a few issues that once resolved I feel will complete the code:

1. The first one is when copying and pasting the data validation, the items are pasted in sequence with quotes, for example:

"HELLOWORLD"

Instead of:


HELLO
WORLD

2. When updating items currently part of my Reference List, the input doesn't update automatically. For Example:

Updating HELLO to HI, the input on the main spreadsheet remains HELLO, even though the Data Validation contains HI.

This in itself causes two other problems within it. First, when adding the new item, the old item is NOT deleted and second, if deleting the single item, the spreadsheet clears the cell (this is an issue if multiple items are on the cell).

I feel these two tweaks will complete this code.

Your help in helping me figure this out would be extremely appreciated!