excel - Excel 下拉框可以作为带有多选复选框的列表框吗？-6ren

excel - Excel 下拉框可以作为带有多选复选框的列表框吗？

转载作者：行者123 更新时间：2023-12-04 20:08:54

我有一个用于产品数据输入的 Excel 工作表。
每个单独的产品使用 16 行。
单元格包含公式、从另一个工作簿验证的下拉框和用于多项选择的列表框，例如颜色。
我需要复制这 16 行以用作新产品的模板，并将其粘贴到上一行的下方，对每个新产品重复此操作。
下拉框可以很好地复制，因为它们位于单元格级别，并允许每个新产品都有自己的下拉框选择。
问题在于复制/粘贴列表框。由于它们没有连接到单元格，并成为具有新名称的副本，因此用于打开/关闭它们并将选择输出到单元格的代码不再起作用。即使它们保持相同的名称，它们也只会与第一个产品相关，并且不允许为每个新产品输入单独的数据。
这是用于控制列表框的代码

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 似乎是一个很好的多选解决方案，同时完善了 1 个虚拟产品的电子表格，但是我看不出它们如何在这个应用程序中为每个新产品工作。有没有其他方法可以实现这一目标？可以将下拉框更改为具有多个选择的复选框，就像 ListBox 一样？
根据此处显示的方法，我已经看到用于多项选择的保管箱:
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在模块全局级别声明(请参阅本文末尾的完整模块)。您可能必须根据需要手动调整宽度和高度常量。
最后， 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 toallow 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