如何实现下拉菜单通过复选框多选

komasun

教程来源于网络将工作表sheet2名称修改为“data”,并在A列输入下拉选项。

插入ListBox（列表框）控件。

1) 在工作表sheet1中，选择A列，点击“开发工具”选项卡，选择“插入”里的“列表框”，放置到A列中。

2） 选中列表框控件，点击“设计模式”，在设计模式下点击“属性”，弹出ListBox属性框，选择“按分类序”。修改MultiSelect项为“1 – fmMultiSelectMulti”，修改ListStyle项为“1 – fmListStyleOption”，设置ListFillRange项为所选菜单选项所在的表格名称和单元格范围，具体格式为“data！A1:A8”。
插入代码。 在Excel中点击开发工具中的“Visual Basic”，打开VB编辑器，在VB编辑器中双击Sheet1，打开sheet1的编辑器，将以下代码粘贴到编辑器中并保存。

在sheet1中保存代码：

1. Private Sub ListBox1_Change()
   
2. 
   
3.     If ReLoad Then Exit Sub '见下方说明
   
4. 
   
5.     For i = 0 To ListBox1.ListCount - 1
   
6. 
   
7.         If ListBox1.Selected(i) = True Then t = t & "," & ListBox1.List(i)
   
8. 
   
9.     Next
   
10. 
    
11.     ActiveCell = Mid(t, 2)
    
12. 
    
13. End Sub
    
14. 
    
15. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
16. 
    
17.     With ListBox1
    
18. 
    
19.         If ActiveCell.Column = 1 And ActiveCell.Row > 1 Then
    
20. 
    
21.             t =ActiveCell.Value
    
22. 
    
23.             ReLoad = True '如果是根据单元格的值修改列表框，则暂时屏蔽listbox的change事件。
    
24. 
    
25.             For i = 0 To .ListCount - 1 '根据活动单元格内容修改列表框中被选中的内容
    
26. 
    
27.                 If InStr(t, .List(i)) Then
    
28. 
    
29.                     .Selected(i) = True
    
30. 
    
31.                     Else
    
32. 
    
33.                     .Selected(i) = False
    
34. 
    
35.                 End If
    
36. 
    
37.             Next
    
38. 
    
39.             ReLoad = False
    
40. 
    
41.             .Top = ActiveCell.Top + ActiveCell.Height '以下语句根据活动单元格位置显示列表框
    
42. 
    
43.             .Left = ActiveCell.Left
    
44. 
    
45.             .Width = ActiveCell.Width
    
46. 
    
47.             .Visible = True
    
48. 
    
49.             Else
    
50. 
    
51.             .Visible = False
    
52. 
    
53.         End If
    
54. 
    
55.     End With
    
56. 
    
57. End Sub

复制代码

在VB编辑器中双击Sheet2，将以下代码粘贴到编辑器中并保存。（该段代码是为了动态设置下拉菜单选项值而加的，如果下拉菜单的选项值固定，可以直接在ListBox的ListFillRange属性中指定，不要以下的代码）

在sheet2（data）中保存代码：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. 
   
3.     Sheets("Sheet1").ListBox1.ListFillRange = "data!a1:a" & Cells(1, 1).End(xlDown).Row
   
4. 
   
5. End Sub

复制代码

将代码保存后，关闭VB编辑器，在sheet1工作表中，点击A列单元格，结果如下图所示。

在模块1中保存：

Public ReLoad As Boolean '开关listbox的change事件

komasun

求助各位大神，如何实现多列下拉菜单多选的效果

komasun

komasun 发表于 2021-12-23 13:22
求助各位大神，如何实现多列下拉菜单多选的效果

Private Sub Worksheet_Change(ByVal Target As Range)
' Developed by Contextures Inc.
' www.contextures.com
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
  If Target.Column = 3 Or Target.Column = 6 Or Target.Column = 1 Then '这里规定好哪一列的数据有效性是多选的，A列是第1列，依次类推，如3就是C列，7就是G列
    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
        If InStr(1, oldVal, newVal) <> 0 Then  '重复选择视同删除
          If InStr(1, oldVal, newVal) + Len(newVal) - 1 = Len(oldVal) Then '最后一个选项重复
            Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 1)
          Else
            Target.Value = Replace(oldVal, newVal & ",", "") '不是最后一个选项重复的时候处理逗号
          End If
        Else '不是重复选项就视同增加选项
        Target.Value = oldVal & "," & newVal
'      NOTE: you can use a line break,
'      instead of a comma
'      Target.Value = oldVal _
'        & Chr(10) & newVal
        End If
      End If
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True
End Sub