[已解决]用VBA代码实现多级数据有效性

grf1973

加了说明，希望有所帮助。

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub     '限定作用范围为[a2:d100]，超出此范围不触发事件
   
3.     c = Target.Column      '当前单元格的列
   
4.     If c = 1 Then    '列数为1，序列为"A,B,C"
   
5.         xstr = "A,B,C"      '一级数据
   
6.     Else '列数大于1
   
7.         sj = Target.Offset(0, -1)   '前一单元格的内容（表示上一级的数据）
   
8.         If sj <> "" Then
   
9.             For i = 1 To 3    '在上一级的基础上后续加1--3作为本级有效性（如果上一级为B,那么本级为b1,b2,b3，如果上一级为b2,那么本级为b21,b22,b23）
   
10.                  xstr = xstr & "," & sj & i
    
11.             Next i
    
12.             xstr = Mid(xstr, 2)    '去掉第一个逗号前的空格
    
13.         End If
    
14.     End If
    
15. 
    
16.     With Target.Validation      '根据xstr的值设置有效性
    
17.       .Delete
    
18.       .Add Type:=xlValidateList, Formula1:=xstr
    
19.     End With
    
20. End Sub
    

复制代码

grf1973

另一代码也作说明。

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Application.EnableEvents = False
   
3.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub       '限定作用范围为[a2:d100]，超出此范围不触发事件
   
4.     c = Target.Column  '当前列
   
5.     If c < 4 Then Target.Offset(, 1).Resize(1, 4 - c) = ""     '如果列数小于4，那么把当前单元格右面单元格直到第4列的单元格内容清空
   
6.     Application.EnableEvents = True
   
7. End Sub

复制代码

grf1973

另一代码修改一下取消激活事件的代码位置。

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub       '限定作用范围为[a2:d100]，超出此范围不触发事件
   
3.     Application.EnableEvents = False    '取消激活事件（即下面的清空单元格内容也是worksheet_change事件，但不希望此事件再次激活）
   
4.     c = Target.Column  '当前列
   
5.     If c < 4 Then Target.Offset(, 1).Resize(1, 4 - c) = ""     '如果列数小于4，那么把当前单元格右面单元格直到第4列的单元格内容清空
   
6.     Application.EnableEvents = True   '恢复激活事件
   
7. End Sub

复制代码

cunfu2010

grf1973 发表于 2016-4-7 16:27
另一代码修改一下取消激活事件的代码位置。

感谢，太有用了，帮忙很大。
还要麻烦你，如果各级数据是附件中的那种有规律的，可以按现在代码实现。但如果：
1、一级数据：小学管理中心，中学管理部，职业学校管理科
2、二级数据：第一小学，第二小学，第三小学，六中，八中，十一中，二十四中，软件学院，职业培训学校
3、三级数据：一年级、二年级、三年级、初一（1）班、初一（3）班、初一（6）班，XX部、XXX部
4、四级数据：一班、三班、五班，张三、李四、王五
像这样不规则的数据，用上述代码就不能实现了。是不是就得用4楼那种代码了？
麻烦你了。能费费事，给写一段代码吗？数据就用上述的。

乐乐2006201506

及时设置最佳答案是一种美德。

cunfu2010

乐乐2006201506 发表于 2016-4-7 20:03
及时设置最佳答案是一种美德。

谢谢提醒，我知道。

grf1973

所以要有对照表

cunfu2010

grf1973 发表于 2016-4-7 23:07
所以要有对照表

谢谢，明白了，工具的应用是为了简便而不是完美。

grf1973

既然你坚持要把有效性全都做在代码里，那么。。。。好吧。。。。。

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub     '限定作用范围为[a2:d100]，超出此范围不触发事件
   
3.     c = Target.Column      '当前单元格的列
   
4.     If c > 1 Then sj = Target.Offset(0, -1) '前一单元格的内容（表示上一级的数据）
   
5.     If c = 1 Then    '列数为1，序列为"A,B,C"
   
6.         xstr = "小学管理中心,中学管理部,职业学校管理科"      '一级数据
   
7.     ElseIf c = 2 Then
   
8.         If sj = "小学管理中心" Then
   
9.             xstr = "第一小学,第二小学,第三小学"
   
10.         ElseIf sj = "中学管理部" Then
    
11.             xstr = "六中,八中,十一中,二十四中"
    
12.         ElseIf sj = "职业学校管理科" Then
    
13.             xstr = "软件学院,职业培训学校"
    
14.         ElseIf sj = "" Then
    
15.             xstr = "第一小学,第二小学,第三小学,六中,八中,十一中,二十四中,软件学院,职业培训学校"
    
16.         End If
    
17.     ElseIf c = 3 Then
    
18.         If InStr(sj, "小学") > 0 Then
    
19.             xstr = "一年级,二年级,三年级"
    
20.         ElseIf InStr(sj, "中") > 0 Then
    
21.             xstr = "初一（1）班,初一（3）班,初一（6）班"
    
22.         ElseIf sj = "软件学院" Or sj = "职业培训学校" Then
    
23.             xstr = "XX部,XXX部"
    
24.         ElseIf sj = "" Then
    
25.             xstr = "一年级,二年级,三年级,初一（1）班,初一（3）班,初一（6）班,XX部,XXX部"
    
26.         End If
    
27.     ElseIf c = 4 Then
    
28.         If InStr(sj, "年级") > 0 Then
    
29.             xstr = "一班,三班,五班"
    
30.         ElseIf InStr(sj, "初") > 0 Then
    
31.             xstr = "张三,李四,王五"
    
32.         ElseIf sj = "" Then
    
33.             xstr = "一班,三班,五班,张三,李四,王五"
    
34.         End If
    
35.     End If
    
36.     If xstr = "" Then Exit Sub
    
37.     With Target.Validation      '根据xstr的值设置有效性
    
38.       .Delete
    
39.       .Add Type:=xlValidateList, Formula1:=xstr
    
40.     End With
    
41. End Sub

复制代码

cunfu2010

grf1973 发表于 2016-4-8 13:53
既然你坚持要把有效性全都做在代码里，那么。。。。好吧。。。。。

grf1973，你太猛了，谢谢！谢谢！全身投地的佩服啊