Multiple selection drop down list

Raymondc190466

New Member
Joined
Aug 19, 2016
Messages
11
Hello All,

I have found the VBA code, and it is working.

But now I want to have a second drop down list starting in G4, with other values.
2 codes with Private Sub Worksheet-Change doesn't work.
How can I solve this?

VBA 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 = 6 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
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
I'm not very sure but this might work:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range, oldVal As String, newVal As String, 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 = 6 Or Target.Column = 7 Then 'Condition added
            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
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,311
In which range is the first drop down and in which range is the second drop down?
 

Raymondc190466

New Member
Joined
Aug 19, 2016
Messages
11
First drop down starts in F4
Second starts in G4

But both can be in different column if this is required.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,311

ADVERTISEMENT

Try:
Rich (BB code):
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Intersect(Target, Range("F:G")) Is Nothing Then Exit Sub
    Dim Oldvalue As String, Newvalue As String
    Application.EnableEvents = False
    Newvalue = Target.Value
    Application.Undo
    Oldvalue = Target.Value
        If Oldvalue = "" Then
          Target.Value = Newvalue
        ElseIf InStr(1, Oldvalue, Newvalue) = 0 Then
          Target.Value = Oldvalue & ", " & Newvalue
        Else
          Target.Value = Oldvalue
        End If
    Application.EnableEvents = True
End Sub
Change the range (in red) to suit your needs.
 
Solution

kanadaaa

Active Member
Joined
Dec 29, 2019
Messages
348
Office Version
  1. 365
Platform
  1. Windows
Yes, just add
VBA Code:
If Target.Row >= 4 Then
End if
Like below:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range, oldVal As String, newVal As String, 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 = 6 Or Target.Column = 7 Then
            If Target.Row >= 4 Then 'Condition added
                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
    End If

exitHandler:
Application.EnableEvents = True
End Sub
But this code has too many nested IFs, so if the code in #5 works, you might want to use it instead.
 

Raymondc190466

New Member
Joined
Aug 19, 2016
Messages
11
Yes, just add
VBA Code:
If Target.Row >= 4 Then
End if
Like below:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDV As Range, oldVal As String, newVal As String, 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 = 6 Or Target.Column = 7 Then
            If Target.Row >= 4 Then 'Condition added
                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
    End If

exitHandler:
Application.EnableEvents = True
End Sub
But this code has too many nested IFs, so if the code in #5 works, you might want to use it instead.
Thank you, I will use code of #5
 

Watch MrExcel Video

Forum statistics

Threads
1,130,106
Messages
5,640,132
Members
417,126
Latest member
Jeffman52

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top