Could an Excel dropdown box behave as a ListBox with checkboxes for Multi Selection?

Question

I have an Excel worksheet used for product data entry. Each individual product uses 16 rows. Cells contain formulas, dropdown boxes that validate from another workbook and ListBoxes for multiple selection of items such as colours.

I need to copy the 16 rows to use as a template for a new product, and paste it below the previous, repeating this for each new product.

The dropdown boxes copy down fine as they are at cell level and allow each new product to have its own dropbox selection.

The issue is with copying/pasting the ListBoxes. As they are not connected to the cells, and become copies with new names, the code used for opening/closing them and outputting selections to a cell no longer works. Even if they remained with the same name they would only be relevant for the first product and not allow for individual data entry for each new product.

Here is the code used to control the ListBoxes

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    With ActiveSheet.ListBox1
        If Target(1).Address = "$A$2" And .Visible = False Then
            .Visible = True
            Application.EnableEvents = False
            [A3].Select
            Application.EnableEvents = True
        Else
            .Visible = False
            For I = 0 To .ListCount - 1
                If .Selected(I) Then txt = txt & ", " & .List(I)
            Next
            [A2] = Mid(txt, 2)  'remove first comma and output to A2 cell
        End If
    End With
End Sub

ListBoxes seemed like a good solution for multiple selections while perfecting the spreadsheet for 1 dummy product, however I don't see how they could work in this application for each new product. Is there any other way to achieve this? Could a dropdown box be altered to have checkboxes for multiple selections as does a ListBox?

I have seen dropboxes used for multiple selections as per the method shown here:

How to Make Multiple Selections in a Drop Down List in Excel

However there is no way to see which items are selected, other than seeing the output in the comma separated list, which could become quite a long list. The selections needs to be visible in the list itself with checkboxes.

Any suggestions would be much appreciated.

user_4717755 · Answer

The solution I came up with does change the look of your listbox somewhat. You were using an ActiveX listbox that gives you the nice-looking checkboxes for your multiselect. The problem I had was assigning a macro to a listbox to catch the OnAction event (each time you click on a listbox item). My solution below works with Forms Listboxes. There are a few parts to the solution.

You stated a requirement that when the user selects a cell in the "Colours" column, a listbox pops up and presents the list of color options. To achieve this, I used the Worksheet_SelectionChange event in the worksheet module:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    Dim colourRange As Range
    Set colourRange = ColourArea(ActiveSheet)
    If colourRange Is Nothing Then Exit Sub
    If Not Intersect(Target, colourRange) Is Nothing Then
        CreateColourPopUp Target
    Else
        DeleteAllPopUps Target
    End If
End Sub

What's important to note here is that the popup is created anytime the user selects a cell in the "Colours" column and whenever a cell is selected outside of that range, the popup is deleted. The ColourArea is defined in a separate module (with all the other code in this answer Module1):

Public Function ColourArea(ByRef ws As Worksheet) As Range
    '--- returns a range for the colour selections for all the products
    '    currently active on the worksheet
    Const COLOUR_COL As Long = 6
    Dim lastRow As Long
    With ws
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        Set ColourArea = .Cells(2, COLOUR_COL).Resize(lastRow, 1)
    End With
End Function

I coded this as separate from the Worksheet_SelectionChange because you may now, or in the future, use some other way to determine what range on the worksheet is used for your colors.

Creating the popup then happens in the code here, where the listbox is created in the cell just below the selected cell. Note again that determining the range that contains the list of colors is encapsulated in a function.

Public Function ColourListArea() As Range
    Set ColourListArea = Sheet1.Range("M1:M11")
End Function

Public Sub DeleteAllPopUps(ByRef selectedCell As Range)
    Dim colourBox As ListBox
    For Each colourBox In selectedCell.Parent.ListBoxes
        colourBox.Delete
    Next colourBox
End Sub

Public Sub CreateColourPopUp(ByRef selectedCell As Range)
    Set colourSelectCell = selectedCell
    
    Dim popUpCell As Range
    Set popUpCell = colourSelectCell.OFFSET(1, 0)
    
    DeleteAllPopUps selectedCell

    '--- now create the one we need, right below the selected cell
    Const POPUP_WIDTH As Double = 75
    Const POPUP_HEIGHT As Double = 110
    Const OFFSET As Double = 5#
    Dim colourBox As ListBox
    Set colourBox = ActiveSheet.ListBoxes.Add(popUpCell.left + OFFSET, _
                                              popUpCell.top + OFFSET, _
                                              POPUP_WIDTH, _
                                              POPUP_HEIGHT)
    With colourBox
        .ListFillRange = ColourListArea().Address
        .LinkedCell = ""
        .MultiSelect = xlSimple
        .Display3DShading = True
        .OnAction = "Module1.ColourBoxClick"
    End With
    
    '--- is there an existing list of colours selected?
    Dim selectedColours() As String
    selectedColours = Split(colourSelectCell.Value, ",")
    Dim colour As Variant
    For Each colour In selectedColours
        Dim i As Long
        For i = 1 To colourBox.ListCount
            If colourBox.List(i) = colour Then
                colourBox.Selected(i) = True
                Exit For
            End If
        Next i
    Next colour
End Sub

The variable colourSelectCell is declared at the module-global level (see the full module at the end of this post). You will likely have to manually adjust the width and height constants as needed.

Finally, the OnAction routine is defined as:

Public Sub ColourBoxClick()
    Dim colourBoxName As String
    colourBoxName = Application.Caller
    
    Dim colourBox As ListBox
    Set colourBox = ActiveSheet.ListBoxes(colourBoxName)

    Dim colourList As String
    Dim i As Long
    For i = 1 To colourBox.ListCount
        If colourBox.Selected(i) Then
            colourList = colourList & colourBox.List(i) & ","
        End If
    Next i
    If Len(colourList) > 0 Then
        colourList = Left$(colourList, Len(colourList) - 1)
    End If
    colourSelectCell.Value = colourList
End Sub

This is where the global colourSelectCell is used.

The entire Module1 is

Option Explicit

Private colourSelectCell As Range

Public Function ColourArea(ByRef ws As Worksheet) As Range
    Const COLOUR_COL As Long = 6
    '--- returns a range for the colour selections for all the products
    '    currently active on the worksheet
    Dim lastRow As Long
    With ws
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
        If lastRow = 0 Then
            Set ColourArea = Nothing
        Else
            Set ColourArea = .Cells(2, COLOUR_COL).Resize(lastRow, 1)
    End With
End Function

Public Sub ColourBoxClick()
    Dim colourBoxName As String
    colourBoxName = Application.Caller
    
    Dim colourBox As ListBox
    Set colourBox = ActiveSheet.ListBoxes(colourBoxName)

    Dim colourList As String
    Dim i As Long
    For i = 1 To colourBox.ListCount
        If colourBox.Selected(i) Then
            colourList = colourList & colourBox.List(i) & ","
        End If
    Next i
    If Len(colourList) > 0 Then
        colourList = Left$(colourList, Len(colourList) - 1)
    End If
    colourSelectCell.Value = colourList
End Sub

Public Function ColourListArea() As Range
    Set ColourListArea = Sheet1.Range("M1:M11")
End Function

Public Sub DeleteAllPopUps(ByRef selectedCell As Range)
    Dim colourBox As ListBox
    For Each colourBox In selectedCell.Parent.ListBoxes
        colourBox.Delete
    Next colourBox
End Sub

Public Sub CreateColourPopUp(ByRef selectedCell As Range)
    Set colourSelectCell = selectedCell
    
    Dim popUpCell As Range
    Set popUpCell = colourSelectCell.OFFSET(1, 0)
    
    DeleteAllPopUps selectedCell

    '--- now create the one we need, right below the selected cell
    Const POPUP_WIDTH As Double = 75
    Const POPUP_HEIGHT As Double = 110
    Const OFFSET As Double = 5#
    Dim colourBox As ListBox
    Set colourBox = ActiveSheet.ListBoxes.Add(popUpCell.left + OFFSET, _
                                              popUpCell.top + OFFSET, _
                                              POPUP_WIDTH, _
                                              POPUP_HEIGHT)
    With colourBox
        .ListFillRange = ColourListArea().Address
        .LinkedCell = ""
        .MultiSelect = xlSimple
        .Display3DShading = True
        .OnAction = "Module1.ColourBoxClick"
    End With
    
    '--- is there an existing list of colours selected?
    Dim selectedColours() As String
    selectedColours = Split(colourSelectCell.Value, ",")
    Dim colour As Variant
    For Each colour In selectedColours
        Dim i As Long
        For i = 1 To colourBox.ListCount
            If colourBox.List(i) = colour Then
                colourBox.Selected(i) = True
                Exit For
            End If
        Next i
    Next colour
End Sub

EDIT: here's an example of returned a discontiguous range of cells to allow the popups. ALSO -- add the line If Target.Cells.Count > 1 Then Exit Sub as shown to the Worksheet_SelectionChange sub so that you don't get errors selecting more than one cell.

Public Function ColourArea(ByRef ws As Worksheet) As Range
    Const COLOUR_COL As Long = 6
    Const PRODUCT_ROWS As Long = 16
    '--- returns a range for the colour selections for all the products
    '    currently active on the worksheet
    Dim lastRow As Long
    With ws
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lastRow = 0 Then
            ColourArea = Nothing
        Else
            Dim numberOfProducts As Long
            numberOfProducts = (lastRow - 1) / PRODUCT_ROWS
        
            '--- now create a Union of the first row of each of these
            '    product areas
            Dim firstRow As Range
            Dim allFirsts As Range
            Set firstRow = ws.Cells(2, COLOUR_COL)
            Set allFirsts = firstRow
        
            Dim i As Long
            For i = 2 To numberOfProducts
                Set firstRow = firstRow.OFFSET(PRODUCT_ROWS, 0)
                Set allFirsts = Application.Union(allFirsts, firstRow)
            Next i
            Set ColourArea = allFirsts
        End If
    End With
End Function

Could an Excel dropdown box behave as a ListBox with checkboxes for Multi Selection?

1 Answers