Forum Discussion

TheodoreHugo's avatar
TheodoreHugo
Copper Contributor
Feb 23, 2025

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 Sub
    

     

    Hiding 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
    

     

    • TheodoreHugo's avatar
      TheodoreHugo
      Copper 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