excel多级联动代码

'源数据按钮代码

'指向以下宏

Option Explicit
Dim Tree '目录树存储每个菜单

Sub main()    '根据数据表初始化弹出菜单
    Dim mybar As Object, arr, i&, j&, key$, myb, pkey$
    Dim N_col As Long '数据区宽度
    On Error Resume Next
    Set Tree = CreateObject("Scripting.Dictionary")    '目录树存储每个菜单
    Application.CommandBars("myCell").Delete    '重设菜单前删除原菜单
    Set mybar = Application.CommandBars.Add(Name:="myCell", position:=msoBarPopup)    '创建弹出式菜单
    Tree.Add "myCell", mybar
    arr = Range("源数据!a1").CurrentRegion.Value    '定位数据区,源数据放入数组arr
    '遍历行,单独写第一列先,避免在后面循环是判断第一个空值key
    N_col = UBound(arr, 2)
    ReDim Preserve arr(1 To UBound(arr, 1), 1 To N_col + 1)    '数组加空列做标识用
    For j = 2 To UBound(arr, 1)
        'xNode.key = arr(j, 1): xNode.text = arr(j, 1): xNode.parentKey = ""
        If Not Tree.exists(arr(j, 1)) Then
            If arr(j, 2) = "" Then    '第二列为空则直接写命令按钮
                AddControlButton "myCell", arr(j, 1), arr(j, 1), j, N_col
            Else    '有下级菜单则添加弹出节点
                AddControlPopup "myCell", arr(j, 1), arr(j, 1)
            End If
        End If
    Next
    '遍历第二列以后的以第一列为基准key
    'Exit Sub
    For i = 2 To UBound(arr)    '遍历数据源行
        key = arr(i, 1)    '关键字从第一列开始
        For j = 2 To N_col  '遍历2-N列
            If arr(i, j) <> "" Then    '空格跳过
                pkey = key    '父节点关键字
                key = key & "\" & arr(i, j) '本级关键字
                If arr(i, j + 1) = "" Then  '下一列为空则直接写命令按钮
                    AddControlButton pkey, key, arr(i, j), i, N_col
                Else    '有下级菜单则添加弹出节点
                    If Not Tree.exists(key) Then    '第一次菜单出现
                        AddControlPopup pkey, key, arr(i, j)
                    End If
                End If
            End If
        Next
    Next
    Set mybar = Nothing
End Sub
'添加菜单命令
Private Sub AddControlButton(ByVal pkey$, ByVal key$, ByVal caption$, ByVal i&, ByVal n&)
    Dim myb
    Set myb = Tree(pkey).Controls.Add(Type:=msoControlButton)
    With myb    '菜单加入触发按钮
        .caption = caption    '菜单按钮名称为x
        .OnAction = "'WriteToRng " & i & "," & n & "'" '最后一级选择触发事件,完成输入
        'Debug.Print "'WriteToRng " & i & "," & n & "'"
    End With
    Tree.Add key, myb
End Sub
'添加弹出菜单节点
Private Sub AddControlPopup(ByVal pkey$, ByVal key$, ByVal caption$)
    Dim myb
    Set myb = Tree(pkey).Controls.Add(Type:=msoControlPopup)
    myb.caption = caption    '菜单按钮名称
    Tree.Add key, myb '加入字典以供下级菜单索引节点用
End Sub
Public Sub WriteToRng(i, N_col)
    ActiveCell.EntireRow.Range("A1").Resize(1, N_col) = Sheets("源数据").Range("A" & i).Resize(1, N_col).Value
End Sub

 

Sub 代码执行时间()
  Dim tim1 As Date, tim2 As Date: tim1 = Timer

'---这中间请放置您要测试执行时间的代码---

   main
  tim2 = Timer
  MsgBox Format(tim2 - tim1, "程序执行时间为：0.00秒"), 64, "时间统计"
End Sub

Public Sub SubPopBar(keys() As Variant)
'根据参数数组返回子菜单,并复制到单独的弹出菜单
    Dim intI As Integer, subB
    Dim mybar As CommandBar
    Set subB = CommandBars("myCell")
    On Error Resume Next
    For intI = 0 To UBound(keys) '获得参数列表的子菜单
        If keys(intI) <> "" Then
            Set subB = subB.Controls(keys(intI))
            '上层是命令项
            If subB.Type = 1 Then Application.CommandBars("myCell").ShowPopup: Exit Sub
        Else
            Application.CommandBars("myCell").ShowPopup '如果前面几列输入的数据为空则直接弹出顶级菜单
            Exit Sub
        End If
    Next intI
    On Error Resume Next
    Application.CommandBars("myCellx").Delete '重设菜单前删除原菜单
    Set mybar = Application.CommandBars.Add(Name:="myCellx", position:=msoBarPopup) '创建弹出式菜单
    For intI = 1 To subB.Controls.Count
        subB.Controls(intI).Copy Bar:=mybar '从顶级菜单中摘出需要的子菜单
    Next
    'Set subB = Nothing
    'Set mybar = Nothing
    Application.CommandBars("myCellx").ShowPopup
End Sub

 

 

'--------------------------------------分割线-------------------------------------

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim a(), i '根据选择项摘取需要的子菜单
On Error Resume Next
If Target.Count = 1 And Target.Row > 1 Then
If Target.Column = 1 Then '若在第一级则直接使用全部菜单
With Application.CommandBars("myCell")
.ShowPopup
End With
ElseIf Target.Column <= Sheets("源数据").UsedRange.Columns.Count Then
ReDim a(0 To Target.Column - 2)
For i = 1 To Target.Column - 1
If Cells(Target.Row, i) <> "" Then
a(i - 1) = Cells(Target.Row, i)
Else
i = Target.Column
End If
Next
Call SubPopBar(a) '若在第N级则弹出N级子菜单
End If
End If
End Sub