如何用VBA实现单元格下拉框复选

金冈刂

老师好！在论坛中看到蓝版帮助了一位网友的贴子，实现多选的案例，我不太会用，在应用到多列时，不会写了。
希望能得到老师的帮助。
非常感谢。

aman1516

试试：

1. <font style="background-color: rgb(255, 255, 255);">Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. On Error Resume Next
   
3. Dim aa, bb, cc
   
4. If Target.Count > 1 Then Exit Sub
   
5. Application.EnableEvents = False
   
6. bb = Target.Value
   
7. If bb <> "" Then
   
8.    aa = Split(bb, ",")
   
9. End If
   
10. cc = Target.Column
    
11. Select Case cc
    
12.     Case 9, 17
    
13.         With ListBox1
    
14.             .Clear
    
15.             .MultiSelect = 1
    
16.             .ListStyle = 0
    
17.             .Top = ActiveCell(1, 2).Top + 17
    
18.             .Left = ActiveCell(1, 2).Left
    
19.             .List = Application.Transpose(Sheets("数据").Range("A1:A" & Sheets("数据").Range("A65536").End(xlUp).Row))
    
20.             .Height = Target.Height * 12
    
21.             .Width = Target.Width + 20
    
22.             .Visible = True
    
23.             If bb <> "" Then
    
24.                For i = 0 To .ListCount - 1
    
25.                    For j = 0 To UBound(aa)
    
26.                        If aa(j) = .List(i) Then .Selected(i) = 1
    
27.                    Next
    
28.                Next
    
29.             End If
    
30.          End With
    
31.          Application.EnableEvents = True
    
32.     Case 8, 16
    
33.         With ListBox1
    
34.             .Clear
    
35.             .MultiSelect = 1
    
36.             .ListStyle = 0
    
37.             .Top = ActiveCell(1, 2).Top + 17
    
38.             .Left = ActiveCell(1, 2).Left
    
39.             .List = Application.Transpose(Sheets("数据").Range("B1:B" & Sheets("数据").Range("B65536").End(xlUp).Row))
    
40.             .Height = Target.Height * 12
    
41.             .Width = Target.Width + 20
    
42.             .Visible = True
    
43.             If bb <> "" Then
    
44.                For i = 0 To .ListCount - 1
    
45.                    For j = 0 To UBound(aa)
    
46.                        If aa(j) = .List(i) Then .Selected(i) = 1
    
47.                    Next
    
48.                Next
    
49.             End If
    
50.          End With
    
51.     Case Else
    
52.          ListBox1.Clear
    
53.          ListBox1.Visible = False
    
54. End Select
    
55. Application.EnableEvents = True
    
56. End Sub</font>

复制代码

aman1516

详见符件： 下拉多选.rar (23.29 KB, 下载次数: 44)

2022-4-30 12:35 上传

点击文件名下载附件

金冈刂

aman1516 发表于 2022-4-30 11:55
详见符件：

谢谢老师，非常感谢！

金冈刂

aman1516 发表于 2022-4-30 11:55
详见符件：

老师，我又增加了一个查找录入的列，也是用的蓝版的代码，但是在做的时侯显示不出来内容，能否再麻烦您给看看。
https://club.excelhome.net/thread-1625958-1-1.html