Forum Discussion
Multi-select dropdowns when answer effects several dependant dropdowns
Hello everyone,
I'm just going to start by saying that while I'm fairly confident with basic excel formulas, this is my first venture into macros and VBA so please be patient with me
The situation:
- I'm trying to manually build a 73 question questionnaire (Forms doesn't have the level of dependant questions/conditional dropdowns that I need)
- The questionnaire has a lot of conditional dropdowns, which I have made with the FILTER formula.
- Some of the questions are single answer only but some of the others are select all that apply. I've managed to make it so multiple answers can be selected on all dropdowns (but I don't know how to turn it off for specific questions)
- Its full functional as long as there is only 1 answer per question but when I have multiple answers, it breaks the conditional dropdowns on the dependant questions...
- I will build the actual form later once I can make the formulas and dropdowns work properly, but for now its just in a rough table. I have one tab for the questions and answer boxes, one tab for formulas, and one tab with all the lists on.
- Also I don't know how to hide questions that don't need answering depending on the answers of previous questions
This is the VBA I've got for multi select dropdowns which I got from https://www.ablebits.com/office-addins-blog/create-multi-select-dropdown-excel/#multi-selection-dropdown-item-removal-code
Any guidance would be much appeciated
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
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
2 Replies
Considering this:
Multi-Select Dropdown for Specific Questions:
Private Sub Worksheet_Change(ByVal Destination As Range) Dim rngMultiSelect As Range Dim rngSingleSelect As Range Dim oldValue As String Dim newValue As String Dim DelimiterType As String DelimiterType = ", " If Destination.Count > 1 Then Exit Sub On Error Resume Next ' Set the ranges for multi-select and single-select dropdowns Set rngMultiSelect = Me.Range("A1:A10") ' Change this to your multi-select range Set rngSingleSelect = Me.Range("B1:B10") ' Change this to your single-select range On Error GoTo exitError If Not Intersect(Destination, rngMultiSelect) Is Nothing Then Call HandleMultiSelect(Destination, DelimiterType) ElseIf Not Intersect(Destination, rngSingleSelect) Is Nothing Then ' Handle single-select dropdowns if needed End If exitError: Application.EnableEvents = True End Sub Private Sub HandleMultiSelect(ByVal Destination As Range, ByVal DelimiterType As String) Dim oldValue As String Dim newValue As String Dim arr() As String Dim i As Integer 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 Then oldValue = "" ElseIf InStr(1, oldValue, newValue) > 0 Then arr = Split(oldValue, DelimiterType) For i = 0 To UBound(arr) If arr(i) = newValue Then arr(i) = "" End If Next i oldValue = Join(arr, DelimiterType) Else oldValue = oldValue & DelimiterType & newValue End If End If Else oldValue = newValue End If Destination.Value = oldValue Application.EnableEvents = True Application.ScreenUpdating = True End SubHiding Questions Based on Previous Answers:
Private Sub Worksheet_Change(ByVal Target As Range) Dim questionRange As Range Set questionRange = Me.Range("C1:C73") ' Change to your question range If Not Intersect(Target, questionRange) Is Nothing Then Call HideQuestionsBasedOnAnswers End If End Sub Private Sub HideQuestionsBasedOnAnswers() Dim questionCell As Range For Each questionCell In Me.Range("C1:C73") ' Change to your question range ' Example condition to hide question if answer is "No" If questionCell.Value = "No" Then questionCell.EntireRow.Hidden = True Else questionCell.EntireRow.Hidden = False End If Next questionCell End Sub- TheodoreHugoCopper Contributor
Hello Kidd_Ip ,
Thank you for your response :)
I think I have done something wrong with the multi selection code. Its applied the single selection/multi selection to the correct cells, and the single selection ones work beautifully. But I'm struggling with the multi-selection ones, it keeps filling up with commas and won't let me clear the cell?
Also, I'm not sure how to apply the hide questions code. In my screenshot above D23 is a yes/no question and if the answer is 'no' I want to hide rows 24:25
Thank you for your time and patience