多级联动及多项选择

aman1516

多级联动下拉列表EH中有不少例子，但很少例涉及到要多项选择的，刚好有个类似的贴子：
多级联动下拉列表能否在最后一级上实现多选
http://club.excelhome.net/thread-1142144-1-1.html
并由 蓝桥玄霜 版 主解决了。但这个只是三级联动的最后一级实现多项选择，而我想实现的是多级联动，且每一级都能实现多项选择，详见附件：
多级联动及多项选择0805.rar (8.62 KB, 下载次数: 602)

2014-8-5 21:19 上传

点击文件名下载附件

因这种情形还是很多时候用到，在此新开贴子，寻求帮助，希望老师指点一下，多级联动每一级皆可实现多选时，如何设置Listbox以及按每级关联关系赋值？

补充：多个选项写入单元格时，在单元格内自动分行显示。

百度不到去谷歌

万变不离其宗 一个联动换成多个本质上不总是最后一级的多选么 只是选择后下级的list查询用上级多选的结果

aman1516

百度不到去谷歌 发表于 2014-8-6 07:21
万变不离其宗 一个联动换成多个本质上不总是最后一级的多选么 只是选择后下级的list查询用上级多选的结果

会者不难，不会者很难，其实VBA方面一直只是入门与摸索学习中。
如果仅仅为实现多项选择，那就简单了，主要是上下级对应不同的多项选择时不同的“关系”，攘得有点乱。

百度不到去谷歌

给你一个案例吧
1-级联列表-多选联动.rar (35.02 KB, 下载次数: 946)

2014-8-6 10:59 上传

点击文件名下载附件

蓝桥玄霜

"多个选项写入单元格时，在单元格内自动分行显示。"
如果第一级多选了，写成了多行；第2级又多选了，在行里面会重叠了。

aman1516

蓝桥玄霜 发表于 2014-8-6 13:01
"多个选项写入单元格时，在单元格内自动分行显示。"
如果第一级多选了，写成了多行；第2级又多选了，在行里 ...

谢谢蓝版主关注，这个“分行”是指在一个单元格内的分行，“Alt+Enter”的形式，并非按行号的分行排列显示。
若简单点，多选的内容还是按“选项1,选项2,选项3……” 这样在的格式也成。

蓝桥玄霜

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. If Target.Count > 1 Then Me.ListBox1.Visible = False: Exit Sub
   
3. If Target.Column < 10 Or Target.Column > 13 Or Target.Row < 3 Then Me.ListBox1.Visible = False: Exit Sub
   
4. Dim i&, j&, k
   
5. If Target.Column = 10 Then
   
6.     Arr = Sheet1.[a2].CurrentRegion
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     Target.Resize(1, 4) = ""
   
9.     For i = 2 To UBound(Arr)
   
10.         If Arr(i, 1) <> "" Then
    
11.             r = r + 1
    
12.             ReDim Preserve Arr1(1 To r)
    
13.             Arr1(r) = i
    
14.             d(Arr(i, 1)) = r
    
15.         End If
    
16.     Next
    
17.     k = d.keys
    
18. ElseIf Target.Column = 11 Then
    
19.     Arr = Sheet1.[a2].CurrentRegion
    
20.     Set d = CreateObject("Scripting.Dictionary")
    
21.     Target.Resize(1, 3) = ""
    
22.     For i = 2 To UBound(Arr)
    
23.         If Arr(i, 1) <> "" Then
    
24.             r = r + 1
    
25.             ReDim Preserve Arr1(1 To r)
    
26.             Arr1(r) = i
    
27.             d(Arr(i, 1)) = r
    
28.         End If
    
29.     Next
    
30.     gs = Target.Offset(0, -1).Value
    
31.     Call yy(gs)
    
32.     k = d1.keys
    
33. ElseIf Target.Column = 12 Then
    
34.     Target.Resize(1, 2) = ""
    
35.     gs = Target.Offset(0, -2).Value: r = 0
    
36.     Arr = Sheet1.[d2].CurrentRegion
    
37.     Set d = CreateObject("Scripting.Dictionary")
    
38.     For i = 2 To UBound(Arr)
    
39.         If Arr(i, 1) <> "" Then
    
40.             r = r + 1
    
41.             ReDim Preserve Arr1(1 To r)
    
42.             Arr1(r) = i
    
43.             d(Arr(i, 1)) = r
    
44.         End If
    
45.     Next
    
46.     Call yy(gs)
    
47.     k = d1.keys
    
48. ElseIf Target.Column = 13 Then
    
49.     gs = Target.Offset(0, -1).Value: r = 0
    
50.     Arr = Sheet1.[g2].CurrentRegion
    
51.     Set d = CreateObject("Scripting.Dictionary")
    
52.     For i = 2 To UBound(Arr)
    
53.         If Arr(i, 1) <> "" Then
    
54.             r = r + 1
    
55.             ReDim Preserve Arr1(1 To r)
    
56.             Arr1(r) = i
    
57.             If InStr(Arr(i, 1), "，") Then
    
58.                 aa = Split(Arr(i, 1), "，")
    
59.                 For j = 0 To UBound(aa)
    
60.                     b = Left(aa(j), Len(aa(j)) - 1)
    
61.                     d(b) = r
    
62.                 Next
    
63.             Else
    
64.                 b = Left(Arr(i, 1), Len(Arr(i, 1)) - 1)
    
65.                 d(b) = r
    
66.             End If
    
67.         End If
    
68.     Next
    
69.     Call yy1(gs)
    
70.     k = d1.keys
    
71. Else
    
72.     Exit Sub
    
73. End If
    
74.     With Me.ListBox1
    
75.         .Clear
    
76.         .Visible = True
    
77.         .List = k
    
78.         .Top = Target.Offset(1, 0).Top
    
79.         .Left = Target.Offset(0, 1).Left
    
80.     End With
    
81. End Sub

复制代码

蓝桥玄霜

请见附件。

aman1516

版主在字典、数组方面十分精通，不知要多久才能达到这程度啊。
ElseIf Target.Column = 11 Then
    If Target.Offset(0, -1) = "" Then Me.ListBox1.Visible = False: MsgBox "请选择上级项目": Exit Sub     '每级选择项增加一句，如果不是逐级选择则跳出，避免出错
……
问题解决了，谢谢版主的热心帮忙，好好学习，努力进步

syym001

好东西   学习了~