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.
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 Subas shown to theWorksheet_SelectionChangesub 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