Dependent Drop-Downs based on Multiple Selection?

[Jezzzza]

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)

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:

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!

 

[kvsrinivasamurthy]

One example given.

Book1.xlsm
	A	B	C	D	E	F	G	H
1
2
3		hd1	hd2	hd3	hd4		hd2,hd3	b2
4		a1	b1	c1	d1		hd1,hd4,hd3	c2
5		a2	b2	c2	d2
6		a3	b3	c3	d3
7		a4	b4		d4
8		a5			d5
9		a6			d6
10
Sheet2

Cells with Data Validation
Cell	Allow	Criteria
H3	List	b1, b2, b3, b4, c1, c2, c3
H4	List	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

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

 

[Jezzzza]

One example given.

Book1.xlsm
	A	B	C	D	E	F	G	H
1
2
3		hd1	hd2	hd3	hd4		hd2,hd3	b2
4		a1	b1	c1	d1		hd1,hd4,hd3	c2
5		a2	b2	c2	d2
6		a3	b3	c3	d3
7		a4	b4		d4
8		a5			d5
9		a6			d6
10
Sheet2

Cells with Data Validation
Cell	Allow	Criteria
H3	List	b1, b2, b3, b4, c1, c2, c3
H4	List	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

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!

 

[kvsrinivasamurthy]

This is separate event. Copy and paste below the present code after
End Sub
line.

 

[Jezzzza]

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?

 

[kvsrinivasamurthy]

This code is for the second drop down only
.Depending on G2 value you will get drop down list in H3 by this code.

 

[Jezzzza]

I did try updating the code to the correct ranges in my sheet, but I am now getting VBA errors. I have uploaded the test sheet with just the two needed tabs showing, any chance you can let me know what is going wrong in this?

https://drive.google.com/file/d/1uO-krVV9tKYobcTdKlBWTgBXNv1kf4w6/view?usp=drive_link

Thanks!

 

[kvsrinivasamurthy]

This code is for the second drop down only
.Depending on G2 value you will get drop down list in H3 by this code.

Link is not working.

 

[Jezzzza]

VBA Test.xlsm

Apologies

link fixed

 

[kvsrinivasamurthy]

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

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