我提出的解决方案确实在一定程度上改变了列表框的外观。您正在使用一个 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 在模块全局级别声明（请参阅本文末尾的完整模块）。您可能需要根据需要手动调整宽度和高度常量。
最后，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
编辑：这是一个返回不连续单元格范围的示例
允许弹出窗口。 ALSO -- 将If Target.Cells.Count > 1 Then Exit Sub 行添加到Worksheet_SelectionChange 子中，这样您在选择多个单元格时就不会出错。
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