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

cunfu2010

想实现用VBA代码制作多级数据有效性下拉选项菜单，借鉴仿写现在实现了两级，后面的多次调试没有成功。求助：
1、现在的代码是不是不够精简？请帮忙精简一下。
2、如何实现多级目的，比如四级、五级等（工作中会用到）。
3、重新选择A列数据时，后面的数据全部清除，待选。
4、把A2实现改成A2：A100实现。
不用辅助表和辅助列（这种情况已经会做），只用代码，谢谢！！！

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    On Error Resume Next
    If Range("A2").Value <> "" Then
      With Range("A2").Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="A,B,C"
    End With
    End If
    If Target.Address = "$A$2" Then '一级数据有效性所在单元格为A2
        If Target.Value <> "" Then
            Dim i%, j(1 To 3) As String, a$
            For i = 1 To 3
                 j(i) = Target.Value & i & ","
            Next i
            a = Left(Join(j), Len(Join(j)) - 1)
        Else
            a = "A1,A2,A3,B1,B2,B3,C1,C2,C3"
        End If
    If Range("B2").Value <> "" Then
      With Range("B2").Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=a
    End With
    End If
    If Range("B2").Value <> "" Then
      With Range("B2").Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=a
    End With
    End If
    If Target.Address = "$B$2" Then '二级数据有效性所在单元格为B2
        If Target.Value <> "" Then
            Dim m%, n(4 To 6) As String, b$
            For m = 4 To 6
                 n(m) = Range("A2").Value & m & ","
            Next m
            b = Left(Join(n), Len(Join(n)) - 1)
        Else
            b = "A4,A5,A6,B4,B5,B6,C4,C5,C6"
        End If
    If Target = "A" Then
        With Target.Offset(0, 1).Validation
            .Delete
            .Add Type:=xlValidateList, Formula1:="=A"
            End With
           End If
        End If
      End If
    Application.EnableEvents = True
End Sub

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-7 14:16

做到4级，100行，单元格改变后，此单元格右边清空

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Application.EnableEvents = False
   
3.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub
   
4.     c = Target.Column
   
5.     If c < 4 Then Target.Offset(, 1).Resize(1, 4 - c) = ""
   
6.     Application.EnableEvents = True
   
7. End Sub
   
8. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
9.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub
   
10.     c = Target.Column
    
11.     If c = 1 Then
    
12.         xstr = "A,B,C"      '一级数据
    
13.     ElseIf c >= 2 Then '二三四级数据
    
14.         sj = Target.Offset(0, -1)   '上一级
    
15.         If sj <> "" Then
    
16.             For i = 1 To 3
    
17.                  xstr = xstr & "," & sj & i
    
18.             Next i
    
19.             xstr = Mid(xstr, 2)
    
20.         End If
    
21.     End If
    
22. 
    
23.     With Target.Validation
    
24.       .Delete
    
25.       .Add Type:=xlValidateList, Formula1:=xstr
    
26.     End With
    
27. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

你应该有个各级的对照表才可以做的。

cunfu2010

grf1973 发表于 2016-4-7 10:56
你应该有个各级的对照表才可以做的。

不用的，第一、二级实现了，代码中直接赋值的。但后面的不会了，帮忙看看

grf1973

有效性一般用selection_change事件激活。

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Intersect(Target, [a2:b2]) Is Nothing Then Exit Sub
   
3.     If Target.Address = "$A$2" Then '一级数据有效性所在单元格为A2
   
4.         xstr = "A,B,C"
   
5.     ElseIf Target.Address = "$B$2" Then  '二级数据有效性所在单元格为B2
   
6.         If [a2] = "" Then
   
7.             xstr = "A1,A2,A3,B1,B2,B3,C1,C2,C3"
   
8.         Else
   
9.             For i = 1 To 3
   
10.                  xstr = xstr & "," & [a2] & i
    
11.             Next i
    
12.             xstr = Mid(xstr, 2)
    
13.         End If
    
14.     End If
    
15. 
    
16.     With Target.Validation
    
17.       .Delete
    
18.       .Add Type:=xlValidateList, Formula1:=xstr
    
19.     End With
    
20. End Sub

复制代码

grf1973

请看附件。

cunfu2010

grf1973 发表于 2016-4-7 13:37
请看附件。

谢谢，代码精简了。其他目的还没有实现呢，能再看看吗？另外，如果是A、B列而不是A2：B2，代码如何改？

grf1973

做到4级，100行，单元格改变后，此单元格右边清空

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Application.EnableEvents = False
   
3.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub
   
4.     c = Target.Column
   
5.     If c < 4 Then Target.Offset(, 1).Resize(1, 4 - c) = ""
   
6.     Application.EnableEvents = True
   
7. End Sub
   
8. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
9.     If Intersect(Target, [a2:d100]) Is Nothing Then Exit Sub
   
10.     c = Target.Column
    
11.     If c = 1 Then
    
12.         xstr = "A,B,C"      '一级数据
    
13.     ElseIf c >= 2 Then '二三四级数据
    
14.         sj = Target.Offset(0, -1)   '上一级
    
15.         If sj <> "" Then
    
16.             For i = 1 To 3
    
17.                  xstr = xstr & "," & sj & i
    
18.             Next i
    
19.             xstr = Mid(xstr, 2)
    
20.         End If
    
21.     End If
    
22. 
    
23.     With Target.Validation
    
24.       .Delete
    
25.       .Add Type:=xlValidateList, Formula1:=xstr
    
26.     End With
    
27. End Sub
    

复制代码

cunfu2010

grf1973 发表于 2016-4-7 14:16
做到4级，100行，单元格改变后，此单元格右边清空

谢谢，真心说一句：你的水平很高。[em17]
你的代码我看不太懂，我刚接触VBA时间不长，能否再麻烦你按4楼的那种方式写一个4级100行，前面单元格空后清空的代码。万分感谢！！！

grf1973

7楼和4楼的代码没有本质区别，只不过2、3、4列写到一起了。

cunfu2010

grf1973 发表于 2016-4-7 15:37
7楼和4楼的代码没有本质区别，只不过2、3、4列写到一起了。

不好意思，因为接触时间不长，我水平确实有限，我试着把7楼的代码分解过，但没成功，所以还是要麻烦你，给写一代通俗易懂的。我两段代码再进行比较。再次感谢