求大神帮忙实现，同一表格 点击不同控件按钮 对应列生成多级菜单

blm860606

1号 表格 两个控件按钮   想实现：  单击按钮1   A列读取李老板的产品数据；单击按钮2  D列读取王老板的产品的数据


我是小白  代码一窍不通，这是复制其他大神的代码，但是想修改下。研究了一天了，弄不成。

blm860606

麻烦各位大神，怎么样在同一个表格，不同按钮对应不同列，实现多级菜单

blm860606

好像上传的表格：没有宏。这里说下吧。。。。
上图模块1因为其他大神的函数：

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
    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)
        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
    For i = 2 To UBound(arr)
        key = arr(i, 1)
        For j = 2 To N_col
            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
        .OnAction = "'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)
    Dim arr
    arr = Sheets("省市区数据").Range("A" & i).Resize(1, N_col).Value
    ActiveCell.Value = Join(Application.Index(arr, 1, 0), "")
End Sub
Sub 测试代码执行时间()
  Dim tim1 As Date



   main
MsgBox "省市区加载成功！请点击A列查看效果！"
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
    Application.CommandBars("myCellx").ShowPopup
End Sub
---------------------------------------------我把”省市县数据：改成李老板的产品

模块2：还是引用上诉代码    ---------------把省市县数据：改成  王老板的产品

sheet1（1号）引用其他大神代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim a(), i
    On Error Resume Next
    If Target.Count = 1 Then
        If Target.Column = 1 Then
            With Application.CommandBars("myCell")
                .ShowPopup
            End With
        End If
    End If
   
End Sub

专搞excel

楼主最好是把你搞的带有原始代码的附件传上来，你表达的很不清楚

blm860606

对不住  这次应该可以了

blm860606

专搞excel 发表于 2018-8-10 16:53
楼主最好是把你搞的带有原始代码的附件传上来，你表达的很不清楚

您在看下，费心了