Excel 下拉框是否可以作为带有多选复选框的列表框？
Could an Excel dropdown box behave as a ListBox with checkboxes for Multi Selection?
我有一个用于输入产品数据的 Excel 工作表。
每个单独的产品使用 16 行。
单元格包含公式、从另一个工作簿验证的下拉框和用于多项选择（例如颜色）的列表框。
我需要复制这 16 行以用作新产品的模板，并将其粘贴到之前的下方，对每个新产品重复此操作。
下拉框在单元格级别可以很好地复制下来，并允许每个新产品都有自己的下拉框选择。
问题出在 copying/pasting 列表框上。由于它们未连接到单元格，并成为具有新名称的副本，因此用于 opening/closing 它们并将选择输出到单元格的代码不再有效。即使它们保留相同的名称，它们也只会与第一个产品相关，并且不允许为每个新产品输入单独的数据。
这是用于控制列表框的代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.ListBox1
If Target(1).Address = "$A" 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 似乎是一个很好的多选解决方案，同时完善了 1 个虚拟产品的电子表格，但是我看不出它们如何在这个应用程序中为每个新产品工作。还有其他方法可以实现这一目标吗？是否可以像列表框一样将下拉框更改为具有多个选择的复选框？
我已经看到按照此处显示的方法用于多项选择的保管箱：
How to Make Multiple Selections in a Drop Down List in Excel
但是，除了在逗号分隔的列表中看到输出外，无法查看选择了哪些项目，这可能会成为一个很长的列表。选择需要在带有复选框的列表中可见。
如有任何建议，我们将不胜感激。
我提出的解决方案确实稍微改变了列表框的外观。您使用的是 ActiveX 列表框，它为您的多选提供了漂亮的复选框。我遇到的问题是将宏分配给列表框以捕获 OnAction 事件（每次单击列表框项目时）。我下面的解决方案适用于表单列表框。解决方案有几个部分。
您陈述了一项要求，即当用户在“颜色”列中选择一个单元格时，会弹出一个列表框并显示颜色选项列表。为此，我在工作表模块中使用了 Worksheet_SelectionChange 事件：
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
这里需要注意的重要一点是，每当用户在“颜色”列中选择一个单元格时都会创建弹出窗口，而只要选择了该范围之外的单元格，弹出窗口就会被删除。 ColourArea 在单独的模块中定义（与此答案中的所有其他代码 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
我将其编码为与 Worksheet_SelectionChange 分开，因为您现在或将来可能会使用其他方式来确定工作表上的哪个范围用于您的颜色。
然后在此处的代码中创建弹出窗口，其中在所选单元格正下方的单元格中创建列表框。再次注意，确定包含颜色列表的范围被封装在一个函数中。
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
变量 colourSelectCell 在模块全局级别声明（请参阅此 post 末尾的完整模块）。您可能必须根据需要手动调整宽度和高度常量。
最后，OnAction例程定义为：
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
这是使用全局 colourSelectCell 的地方。
整个Module1是
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
我有一个用于输入产品数据的 Excel 工作表。 每个单独的产品使用 16 行。 单元格包含公式、从另一个工作簿验证的下拉框和用于多项选择（例如颜色）的列表框。
我需要复制这 16 行以用作新产品的模板，并将其粘贴到之前的下方，对每个新产品重复此操作。
下拉框在单元格级别可以很好地复制下来，并允许每个新产品都有自己的下拉框选择。
问题出在 copying/pasting 列表框上。由于它们未连接到单元格，并成为具有新名称的副本，因此用于 opening/closing 它们并将选择输出到单元格的代码不再有效。即使它们保留相同的名称，它们也只会与第一个产品相关，并且不允许为每个新产品输入单独的数据。
这是用于控制列表框的代码
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.ListBox1
If Target(1).Address = "$A" 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 似乎是一个很好的多选解决方案，同时完善了 1 个虚拟产品的电子表格，但是我看不出它们如何在这个应用程序中为每个新产品工作。还有其他方法可以实现这一目标吗？是否可以像列表框一样将下拉框更改为具有多个选择的复选框？
我已经看到按照此处显示的方法用于多项选择的保管箱：
How to Make Multiple Selections in a Drop Down List in Excel
但是，除了在逗号分隔的列表中看到输出外，无法查看选择了哪些项目，这可能会成为一个很长的列表。选择需要在带有复选框的列表中可见。
如有任何建议，我们将不胜感激。
我提出的解决方案确实稍微改变了列表框的外观。您使用的是 ActiveX 列表框，它为您的多选提供了漂亮的复选框。我遇到的问题是将宏分配给列表框以捕获 OnAction 事件（每次单击列表框项目时）。我下面的解决方案适用于表单列表框。解决方案有几个部分。
您陈述了一项要求，即当用户在“颜色”列中选择一个单元格时，会弹出一个列表框并显示颜色选项列表。为此，我在工作表模块中使用了 Worksheet_SelectionChange 事件：
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
这里需要注意的重要一点是，每当用户在“颜色”列中选择一个单元格时都会创建弹出窗口，而只要选择了该范围之外的单元格，弹出窗口就会被删除。 ColourArea 在单独的模块中定义（与此答案中的所有其他代码 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
我将其编码为与 Worksheet_SelectionChange 分开，因为您现在或将来可能会使用其他方式来确定工作表上的哪个范围用于您的颜色。
然后在此处的代码中创建弹出窗口，其中在所选单元格正下方的单元格中创建列表框。再次注意，确定包含颜色列表的范围被封装在一个函数中。
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
变量 colourSelectCell 在模块全局级别声明（请参阅此 post 末尾的完整模块）。您可能必须根据需要手动调整宽度和高度常量。
最后，OnAction例程定义为：
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
这是使用全局 colourSelectCell 的地方。
整个Module1是
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