VBA excel的多级联动下拉表格
最近需要一个excel的多级联动下拉表格，在网上找到的要么不完美，要么不能用，都不满足需求，于是自己基于别人的二级联动代码，用VBA重新做一个6级联动，可以根据需要增减级，我觉得功能完美，跟原代码已经完全不同，内有备注，有需要的拿去。Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next '以下代码出现错误 继续执行
If Target.Count <> 1 Then Exit Sub '如果目标单元格不是1个 则退出
If Target.Column <> 6 Then Exit Sub'如果 目标列不是6 退出
myarr = Sheets("Sheet2").Range("b2:g734") '将数据装入数组
If UBound(myarr) < 3 Then Exit Sub'如果数组的成员数量小于3，则退出
Set myDic = CreateObject("Scripting.Dictionary") '建立一级菜单空字典
If Target.Column = 6 Then '如果目标列是6，那么执行以下循环
For i = 1 To UBound(myarr) '循环将数组内容写入一级菜单
If myarr(i, 1) <> "" Then myDic(myarr(i, 1)) = "" '将菜单值写入字典的键 如果数组成员内容不等空，则写入一级菜单
Next '循环
'一级菜单实现
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(myDic.keys, ",")
End With
End If
Set myDic = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next '以下代码出现错误 继续执行
If Target.Count <> 1 Then Exit Sub
If Target.Column < 6 And Target.Column > 11 Then Exit Sub'如果 目标列小于6或大于11 退出
myarr = Sheets("Sheet2").Range("b2:g734") '将数据装入数组
If UBound(myarr) < 3 Then Exit Sub'如果数组的成员数量小于3，则退出
Set mytwoDic = CreateObject("Scripting.Dictionary") '建立二级菜单空字典
Set mytthDic = CreateObject("Scripting.Dictionary") '建立三级菜单空字典
Set mytfoDic = CreateObject("Scripting.Dictionary") '建立四级菜单空字典
Set mytfiDic = CreateObject("Scripting.Dictionary") '建立五级菜单空字典
Set mytseDic = CreateObject("Scripting.Dictionary") '建立六级菜单空字典
'二级菜单实现
Select Case Target.Column
Case 6'如果目标列是6，则执行
For i = 1 To UBound(myarr) '循环数组成员数，myarr为初始数组
T = myarr(i, 1) 'T为首列内容
If T = Target.Value Then '如果T等于左侧单元格内容
mytwoDic(myarr(i, 2)) = myarr(i, 2) '将菜单值写入键，写二级菜单到数组
End If
Next
Application.EnableEvents = False
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(mytwoDic.keys, ",")
End With
Target.Offset(0, 5).Validation.Delete '删除对象
Target.Offset(0, 4).Validation.Delete
Target.Offset(0, 3).Validation.Delete
Target.Offset(0, 2).Validation.Delete
Target.Offset(0, 1) = "" '删除内容
Target.Offset(0, 2) = ""
Target.Offset(0, 3) = ""
Target.Offset(0, 4) = ""
Target.Offset(0, 5) = ""
Target.Offset(0, 6) = ""
Application.EnableEvents = True
'三级菜单实现
Case 7'如果目标列是7
For i = 1 To UBound(myarr) '循环数组成员数，myarr为初始数组
T = myarr(i, 2) 'T为首列内容
T1 = myarr(i, 1)
If T = Target.Value And Target.Offset(0, -1).Value = T1 Then'数据比对筛选
mytthDic(myarr(i, 3)) = myarr(i, 3) '将菜单值写入键，写三级菜单到数组
End If
Next
Application.EnableEvents = False
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(mytthDic.keys, ",")
End With
Target.Offset(0, 4).Validation.Delete '删除对象
Target.Offset(0, 3).Validation.Delete
Target.Offset(0, 2).Validation.Delete
Target.Offset(0, 1) = "" '删除内容
Target.Offset(0, 2) = ""
Target.Offset(0, 3) = ""
Target.Offset(0, 4) = ""
Target.Offset(0, 5) = ""
Application.EnableEvents = True
'四级菜单实现
Case 8'如果目标列是8，则执行
For i = 1 To UBound(myarr) '循环数组成员数，myarr为初始数组
T = myarr(i, 3) 'T为首列内容
T1 = myarr(i, 1)
T2 = myarr(i, 2)
If T = Target.Value And Target.Offset(0, -2).Value = T1 And Target.Offset(0, -1).Value = T2 Then'数据比对筛选
mytfoDic(myarr(i, 4)) = myarr(i, 4) '将菜单值写入键，四级菜单到数组
End If
Next
Application.EnableEvents = False
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(mytfoDic.keys, ",")
End With
Target.Offset(0, 3).Validation.Delete '删除对象
Target.Offset(0, 2).Validation.Delete
Target.Offset(0, 1) = "" '删除内容
Target.Offset(0, 2) = ""
Target.Offset(0, 3) = ""
Target.Offset(0, 4) = ""
Application.EnableEvents = True
Case 9'如果目标列是9
For i = 1 To UBound(myarr) '循环数组成员数，myarr为初始数组
T = myarr(i, 4)
T1 = myarr(i, 1)
T2 = myarr(i, 2)
If T = Target.Value And Target.Offset(0, -3).Value = T1 And Target.Offset(0, -2).Value = T2 Then
mytfiDic(myarr(i, 5)) = myarr(i, 5)
End If
Next
Application.EnableEvents = False
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(mytfiDic.keys, ",")
End With
Target.Offset(0, 2).Validation.Delete
Target.Offset(0, 1) = ""
Target.Offset(0, 2) = ""
Target.Offset(0, 3) = ""
Application.EnableEvents = True
Case 10
For i = 1 To UBound(myarr)
T = myarr(i, 5)
T1 = myarr(i, 1)
If T = Target.Value And Target.Offset(0, -4).Value = T1 Then
mytseDic(myarr(i, 6)) = myarr(i, 6)
End If
Next
Application.EnableEvents = False
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(mytseDic.keys, ",")
End With
Target.Offset(0, 1) = ""
Target.Offset(0, 2) = ""
Application.EnableEvents = True
End Select
Set mytwoDic = Nothing
Set mytthDic = Nothing
Set mytfoDic = Nothing
Set mytfiDic = Nothing
Set mytseDic = Nothing
End Sub
页:
[1]