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!
 
Apologies, one more thing, I need to be able to multi-select in the second drop-down as well as the first, I updated some of the code in the first Sub but it is not working, any ideas?

I updated this to include a range rather than just cell B19
If rngDropdown Is Nothing Then GoTo exitError
If Not Destination.Address = "$B$19:$B$20" Then GoTo exitError

and I moved a few rows around, first drop down: B19; second: B20
1741111153756.png


Shared File

Thanks again
 
Upvote 0
Hi,

As in my last screenshot, I moved the two lines with the drop downs to be cells B19 and B20, which I updated in the first part of the code (not your code) and now I'm getting an error in this line of your code:

If Target.Cells.Count > 1 Or Target.Offset(0, -1) = "" Then Exit Sub

I need the both dropdowns to be able to do multi-select, which the first code string should do, but then I need the second dropdown (b20) to be dependent on the first, and pull in all results for all items selected in B19, and also from those results be multi-selectable.

1741189914853.png


Full Code:

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 Destination.Address <> "$B$20" And Destination.Address <> "$B$21" 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


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("B19"), ", ")
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

I have updated the SHARED FILE

I hope this explanation is clear. Thank you so much.
 
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