多级菜单非递归算法/示例-全国省市行政区划三级菜单/自适应级数

沧海戏浪

百度老师，我是一个VBA盲。看了您的多级菜单，太羡慕。把您的代码MAIN部分的遍历行改成了一次，本机测试发现可以快0.02秒。但是不知道这样有没有副作用。有时间的话，盼回复。
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)
    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)    '???????????????
    '???????????????????????key
    'Exit Sub
    For i = 2 To UBound(arr)    '???????????
            If Not Tree.exists(arr(i, 1)) Then
            If arr(i, 2) = "" Then    '?????????????д?????
                AddControlButton "myCell", arr(i, 1), arr(i, 1), i, N_col
            Else    '???????????????????
                AddControlPopup "myCell", arr(i, 1), arr(i, 1)
            End If
        End If
        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

沧海戏浪

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)    '???????????????

    '???????????????????????key
    'Exit Sub
    For i = 2 To UBound(arr)    '???????????
            If Not Tree.exists(arr(i, 1)) Then
            If arr(i, 2) = "" Then    '?????????????д?????
                AddControlButton "myCell", arr(i, 1), arr(i, 1), i, N_col
            Else    '???????????????????
                AddControlPopup "myCell", arr(i, 1), arr(i, 1)
            End If
        End If
        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

沧海戏浪

沧海戏浪 发表于 2020-4-28 18:04
百度老师，我是一个VBA盲。看了您的多级菜单，太羡慕。把您的代码MAIN部分的遍历行改成了一次，本机测试发 ...

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)    '???????????????

    '???????????????????????key
    'Exit Sub
    For i = 2 To UBound(arr)    '???????????
            If Not Tree.exists(arr(i, 1)) Then
            If arr(i, 2) = "" Then    '?????????????д?????
                AddControlButton "myCell", arr(i, 1), arr(i, 1), i, N_col
            Else    '???????????????????
                AddControlPopup "myCell", arr(i, 1), arr(i, 1)
            End If
        End If
        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

沧海戏浪

dogingate 发表于 2018-7-9 00:04
我这个还没有做到自适应，主要是针对行政划分这个三级菜单而修改的代码，原代码加载时间为11.31s，修改之后 ...

实测，当上级列输入内容不在菜单中时，会报错。比如第一列输入的是武汉，但是武汉在一级菜单中是没有的，点第二列的时候，就会报错。其实三级菜单已经够用了，用不了自适应。

cvc2004

非常好。收藏了慢慢看

yglm

大神级别的

lyr227

看起来好高大上，看来我也要学习VBA了

xsy我可以很好

学习为了成长，收获必须分享。感谢楼主无私奉献！
修改为六级行政区划会报错，强制纠错后，加载菜单用时两分钟。

zminzhu

下载，学习了。谢谢分享

dengcaimao

都是大神啊，对提高工作效率大有帮助。