VBA excel的多级联动下拉表格

csx

最近需要一个excel的多级联动下拉表格，在网上找到的要么不完美，要么不能用，都不满足需求，于是自己基于别人的二级联动代码，用VBA重新做一个6级联动，可以根据需要增减级，我觉得功能完美，跟原代码已经完全不同，内有备注，有需要的拿去。

[Visual Basic] 纯文本查看 复制代码

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

VBA excel表格6级下拉联动.rar (27.03 KB, 下载次数: 0)

2021-12-26 01:48 上传

点击文件名下载附件