Dependent Drop-Downs based on Multiple Selection?

Jezzzza

New Member
Joined
Jun 29, 2023
Messages
16
Office Version
  1. 365
Platform
  1. MacOS
Hi,

I have a worksheet in which I have used VBA to allow a multi-selection in a drop down data validation list. I then have a dependent data validation list that I need to pull all values based on the selection or selections made in the first drop-down.

First drop-down (with two items selected)
1741049115812.png


In the second dependent drop-down, using the indirect function I assume, I would like to then see the full list of anything selected in the initial drop-down list using the ranges with corresponding labels:

1741049361047.png


VBA Code for reference:
VBA:

----------------------------------

Option Explicit
Private Sub Worksheet_Change(ByVal Destination As Range)
Dim rngDropdown As Range
Dim oldValue As String
Dim newValue As String
Dim DelimiterType As String
DelimiterType = ", "
Dim DelimiterCount As Integer
Dim TargetType As Integer
Dim i As Integer
Dim arr() As String

If Destination.Count > 1 Then Exit Sub
On Error Resume Next

Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitError

If rngDropdown Is Nothing Then GoTo exitError
If Not Destination.Address = "$B$18" Then GoTo exitError

TargetType = 0
TargetType = Destination.Validation.Type
If TargetType = 3 Then ' is validation type is "list"
Application.ScreenUpdating = False
Application.EnableEvents = False
newValue = Destination.Value
Application.Undo
oldValue = Destination.Value
Destination.Value = newValue
If oldValue <> "" Then
If newValue <> "" Then
If oldValue = newValue Or oldValue = newValue & Replace(DelimiterType, " ", "") Or oldValue = newValue & DelimiterType Then ' leave the value if there is only one in the list
oldValue = Replace(oldValue, DelimiterType, "")
oldValue = Replace(oldValue, Replace(DelimiterType, " ", ""), "")
Destination.Value = oldValue
ElseIf InStr(1, oldValue, DelimiterType & newValue) Or InStr(1, oldValue, newValue & DelimiterType) Or InStr(1, oldValue, DelimiterType & newValue & DelimiterType) Then
arr = Split(oldValue, DelimiterType)
If Not IsError(Application.Match(newValue, arr, 0)) = 0 Then
Destination.Value = oldValue & DelimiterType & newValue
Else:
Destination.Value = ""
For i = 0 To UBound(arr)
If arr(i) <> newValue Then
Destination.Value = Destination.Value & arr(i) & DelimiterType
End If
Next i
Destination.Value = Left(Destination.Value, Len(Destination.Value) - Len(DelimiterType))
End If
ElseIf InStr(1, oldValue, newValue & Replace(DelimiterType, " ", "")) Then
oldValue = Replace(oldValue, newValue, "")
Destination.Value = oldValue
Else
Destination.Value = oldValue & DelimiterType & newValue
End If
Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", "") & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", "")) ' remove extra commas and spaces
Destination.Value = Replace(Destination.Value, DelimiterType & Replace(DelimiterType, " ", ""), Replace(DelimiterType, " ", ""))
If Destination.Value <> "" Then
If Right(Destination.Value, 2) = DelimiterType Then ' remove delimiter at the end
Destination.Value = Left(Destination.Value, Len(Destination.Value) - 2)
End If
End If
If InStr(1, Destination.Value, DelimiterType) = 1 Then ' remove delimiter as first characters
Destination.Value = Replace(Destination.Value, DelimiterType, "", 1, 1)
End If
If InStr(1, Destination.Value, Replace(DelimiterType, " ", "")) = 1 Then
Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "", 1, 1)
End If
DelimiterCount = 0
For i = 1 To Len(Destination.Value)
If InStr(i, Destination.Value, Replace(DelimiterType, " ", "")) Then
DelimiterCount = DelimiterCount + 1
End If
Next i
If DelimiterCount = 1 Then ' remove delimiter if last character
Destination.Value = Replace(Destination.Value, DelimiterType, "")
Destination.Value = Replace(Destination.Value, Replace(DelimiterType, " ", ""), "")
End If
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End If

exitError:
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub
----------------------------------


Is this possible?

Any help is appreciated!
 
One example given.
Book1.xlsm
ABCDEFGH
1
2
3hd1hd2hd3hd4hd2,hd3b2
4a1b1c1d1hd1,hd4,hd3c2
5a2b2c2d2
6a3b3c3d3
7a4b4d4
8a5d5
9a6d6
10
Sheet2
Cells with Data Validation
CellAllowCriteria
H3List b1, b2, b3, b4, c1, c2, c3
H4List a1, a2, a3, a4, a5, a6, d1, d2, d3, d4, d5, d6, c1, c2, c3

Validation range chosen is H3:H10, change as required in code. You will get required drop down list.
Code for worksheet event for Sheet2
VBA Code:
Private Sub Worksheet_selectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("H3:H10")) Is Nothing Then
If Target.Cells.Count > 1 Or Target.Offset(0, -1) = "" Then Exit Sub
On Error GoTo Line1
Application.EnableEvents = False
Dim M, A
Dim HdrRng As Range
Dim Ta&, Tb&, Clm&, S$
Set HdrRng = Range("B3:E3")
A = Sheets("Sheet2").Range("B4:E9")
M = Split(Target.Offset(0, -1), ",")
For Ta = LBound(M) To UBound(M)
Clm = Application.Match(M(Ta), HdrRng, 0)
    For Tb = 1 To UBound(A, 1)
    If A(Tb, Clm) = "" Then
    Exit For
    Else
    S = S & ", " & A(Tb, Clm)
    End If
    Next Tb
Next Ta
If Len(S) > 0 Then

    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Mid(S, 2)
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End If
Line1
Application.EnableEvents = True
End If
End Sub
 
Last edited:
Upvote 0
One example given.
Book1.xlsm
ABCDEFGH
1
2
3hd1hd2hd3hd4hd2,hd3b2
4a1b1c1d1hd1,hd4,hd3c2
5a2b2c2d2
6a3b3c3d3
7a4b4d4
8a5d5
9a6d6
10
Sheet2
Cells with Data Validation
CellAllowCriteria
H3List b1, b2, b3, b4, c1, c2, c3
H4List a1, a2, a3, a4, a5, a6, d1, d2, d3, d4, d5, d6, c1, c2, c3

Validation range chosen is H3:H10, change as required in code. You will get required drop down list.
Code for worksheet event for Sheet2
VBA Code:
Private Sub Worksheet_selectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("H3:H10")) Is Nothing Then
If Target.Cells.Count > 1 Or Target.Offset(0, -1) = "" Then Exit Sub
On Error GoTo Line1
Application.EnableEvents = False
Dim M, A
Dim HdrRng As Range
Dim Ta&, Tb&, Clm&, S$
Set HdrRng = Range("B3:E3")
A = Sheets("Sheet2").Range("B4:E9")
M = Split(Target.Offset(0, -1), ",")
For Ta = LBound(M) To UBound(M)
Clm = Application.Match(M(Ta), HdrRng, 0)
    For Tb = 1 To UBound(A, 1)
    If A(Tb, Clm) = "" Then
    Exit For
    Else
    S = S & ", " & A(Tb, Clm)
    End If
    Next Tb
Next Ta
If Len(S) > 0 Then

    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Mid(S, 2)
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End If
Line1
Application.EnableEvents = True
End If
End Sub
Will I need to replace my VBA with this new code, or add it to what I have? If add, where should it be inserted? Thanks!
 
Upvote 0
Thanks,

For the second dropdown, which is dependent on the selections in the first, what formula should I be using in the list source for it to pull all list data in for all selections?
 
Upvote 0
I have made suitable changes in code. Put this code.
For multiple selection in B18, you will get required list for DV in B20 when B20 is selected. When B20 is selected old value is erased in B20 and drop down list is available for that cell.
New Code
VBA Code:
Private Sub Worksheet_selectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("B20")) Is Nothing Then
If Target.Cells.Count > 1 Or Target.Offset(0, -1) = "" Then Exit Sub
On Error GoTo Line1
Application.EnableEvents = False
Dim M, A
Dim HdrRng As Range
Dim Ta&, Tb&, Clm&, S$
Set HdrRng = Sheets("LookupData").Range("A1:I1")
A = Sheets("LookupData").Range("A2:I8")
M = Split(Range("B18"), ", ")
Target = ""
For Ta = LBound(M) To UBound(M)
Clm = Application.Match(M(Ta), HdrRng, 0)
    For Tb = 1 To UBound(A, 1)
    If A(Tb, Clm) = "" Then
    Exit For
    Else
    S = S & ", " & A(Tb, Clm)
    End If
    Next Tb
Next Ta
If Len(S) > 0 Then

    With Target.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Mid(S, 2)
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End If
Line1:
Application.EnableEvents = True
End If
End Sub
 
Upvote 0

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
Back
Top