如何在VBA中实现下拉复选框

dengshuang

附件之前论坛另一位大师做的，但是我在使用后发现几个问题
1.选择后需要在复选框空白处双击才能完成录入，如何实现勾选后自动录入，或勾选完成后点击其他单元格或按回车就自动完成录入
2.再次对一个单元格勾选的话每次都要全部重新勾选，如何实现重新勾选时留有原来已经够选好的选项，只需要增加或减少某个选项就行。
3.实现多列复选框的时候，必须两列紧挨着，，且设置“值”的时候必须要挪到这两列对应的前一列，如何实现可以设置任意两列或多列。

dengshuang

第一次发帖，上传多了，复选2才是正确的附件

蓝桥玄霜

1. Dim d
   
2. Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   
3.     If KeyCode = 13 Then
   
4.     If ListBox1.ListIndex = -1 Then Exit Sub
   
5.     Dim i&, s$
   
6.     With ListBox1
   
7.         For i = 0 To .ListCount - 1
   
8.             If .Selected(i) Then s = s & "," & .List(i)
   
9.         Next
   
10.         .TopLeftCell.Offset(, -1).Value = Mid(s, 2)
    
11.         .Visible = False
    
12.     End With
    
13.     End If
    
14. End Sub
    
15. 
    
16. 
    
17. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
18.     If Target.Count > 1 Then Exit Sub
    
19.     If Target.Row > 2 And (Target.Column = 2 Or Target.Column = 3) Then
    
20.         Dim arr, c&, i&, Brr, bt, r1, aa, bb$, j&
    
21.         Set d = CreateObject("Scripting.Dictionary")
    
22.         If Target <> "" Then
    
23.             If InStr(Target.Value, ",") Then
    
24.                 aa = Split(Target.Value, ",")
    
25.             Else
    
26.                 bb = Target.Value
    
27.             End If
    
28.         End If
    
29.         Brr = [a1].CurrentRegion
    
30.         For i = 1 To UBound(Brr, 2)
    
31.             d(Brr(2, i)) = i
    
32.         Next
    
33.         bt = Brr(2, Target.Column)
    
34.         Set r1 = Sheets("值").Rows(1).Find(bt, , , 1)
    
35.         c = r1.Column
    
36.         arr = Sheets("值").Cells(2, c).Resize(Sheets("值").Cells(Rows.Count, c).End(xlUp).Row - 1)
    
37.         With ListBox1
    
38.             .MultiSelect = 1
    
39.             .ListStyle = 1
    
40.             .List = arr
    
41.             .Top = Target.Top
    
42.             .Left = Target.Left + Target.Width
    
43.             .Height = Target.Height * 9
    
44.             .Width = 90
    
45.             .Visible = True
    
46.             For i = 0 To .ListCount - 1
    
47.                 If bb <> "" Then
    
48.                     If bb = .List(i) Then .Selected(i) = 1
    
49.                 Else
    
50.                     For j = 0 To UBound(aa)
    
51.                         If aa(j) = .List(i) Then .Selected(i) = 1
    
52.                     Next
    
53.                 End If
    
54.             Next
    
55. 
    
56.         End With
    
57.     Else
    
58.         ListBox1.Clear
    
59.         ListBox1.Visible = False
    
60.     End If
    
61. End Sub

复制代码

选择后按回车实现。

dengshuang

蓝桥玄霜 发表于 2016-5-9 10:07
选择后按回车实现。

谢谢您！！

cunfu2010

蓝桥玄霜 发表于 2016-5-9 10:07
选择后按回车实现。

蓝版你好，代码放入后，如果点击空白单元格会提示类型不匹配

cunfu2010

蓝桥玄霜 发表于 2016-5-9 10:07
选择后按回车实现。

另外，这个附件中，单击A2会自动添加“北京”，而单击A3双会自动删除“北京”，这是为什么？

蓝桥玄霜

cunfu2010 发表于 2016-12-9 13:56
蓝版你好，代码放入后，如果点击空白单元格会提示类型不匹配

经测试是正常的，没有发现问题。

蓝桥玄霜

请见附件。

cunfu2010

蓝桥玄霜 发表于 2016-12-10 12:25
请见附件。

谢谢，还是有这个问题：单击A2会自动添加“北京”，而单击A3双会自动删除“北京”。
见附件。

740688321

蓝桥玄霜 发表于 2016-12-10 12:25
请见附件。

请问版主，这什么这个excelhome论坛上传excel附件还需要压缩，难道不能改进一下？