VBA实战(Excel)(2)：下拉菜单实现快速输入

1.实现效果

 2.作用

        实现多列内容的点选输入，适用于含有一定关联关系的两列内容，此案例为工艺路线中具体加工机床与工序名称含有关系，提前设置好关系表，在输入工序时同时选择对应机床。

 3.代码实现

3.1在sheet中粘贴如下代码，设置对单元格选中的响应事件

Dim z

Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal HDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal HDC As Long) As Long

Private Const LOGPIXELSX            As Long = 88

Private Function PointsPerPixel() As Double
    Dim HDC As Long
    Dim lngPotsPerInch As Long
    HDC = GetDC(0)
    lngPotsPerInch = GetDeviceCaps(HDC, LOGPIXELSX)
    PointsPerPixel = Application.InchesToPoints(1) / lngPotsPerInch
    ReleaseDC 0, HDC
End Function


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    'If Sheets("数据").Cells(1, 5) = False Then
    'Call main '菜单初始化
    'Sheets("数据").Cells(1, 5) = True
    'End If
    For h = 4 To 20
    If IsNumeric(Cells(h, 1)) And Cells(h, 2) = "" Then
    Cells(h, 6) = ""
    Cells(h, 7) = ""
    End If
    Next
    Dim rng As Range, X As Single, Y As Single, DZoom As Single, X0 As Single, Y0 As Single
    Set rng = ActiveCell
    With ActiveWindow
    DZoom = .Zoom / 100
        X = .PointsToScreenPixelsX((rng.Left + rng.Width) / PointsPerPixel * DZoom)
        Y = .PointsToScreenPixelsY((rng.Top) / PointsPerPixel * DZoom)
    End With
    Dim a(), i '根据选择项摘取需要的子菜单
    On Error Resume Next '发生错误时执行下一句代码

    If Target.Count = 1 And Target.Row > 1 Then '只选中了一格且所在行数大于1
        If Target.Column = 2 Then '若在第一列则直接使用全部菜单
            With Application.CommandBars("myCell")
                .ShowPopup X, Y
            End With
        End If
    End If
End Sub

3.2 在模块中粘贴如下代码，设置下拉框的级数和相应的点击响应事件

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（currentregion：获取单元格所在的有数据的矩形区域）
    N_col = UBound(arr, 2) '返回数组第二维最大下标(列数)
    Debug.Print "数据区的行数为：" & UBound(arr, 1) '行数
    Debug.Print "数据区的列数为：" & UBound(arr, 2)
    ReDim Preserve arr(1 To UBound(arr, 1), 1 To N_col + 1)    '数组加空列做标识用
    For i = 2 To UBound(arr, 1)    '遍历行,单独写第一列先,避免在后面循环是判断第一个空值key
        'xNode.key = arr(i, 1): xNode.text = arr(i, 1): xNode.parentKey = ""
        If Not Tree.exists(arr(i, 1)) Then
            If arr(i, 2) = "" Then  '第二列为空则直接写命令按钮
                AddControlButton "myCell", arr(i, 1), arr(i, 1), i, N_col '调用子函数1
            Else    '有下级菜单则添加弹出节点
                AddControlPopup "myCell", arr(i, 1), arr(i, 1) '调用子函数2
            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    '第一次菜单出现
                    If arr(i, 2) = arr(i + 1, 2) Then
                        AddControlPopup pkey, key, arr(i, j)
                        Else
                        AddControlButton pkey, key, arr(i, j), i, N_col
                    End If
                    End If
                End If
            End If
        Next
    Next
    Set mybar = Nothing
End Sub

'添加菜单命令（子函数1）能展开
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 & "'" '最后一级选择触发事件,完成输入，调用子函数3
        'Debug.Print "'WriteToRng " & i & "," & n & "'"
    End With
    Tree.Add key, myb
End Sub

'添加弹出菜单节点（子函数2），不能展开
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

'子函数3
Public Sub WriteToRng(i, N_col)
    Debug.Print "'WriteToRng " & N_col
    'ActiveCell.EntireRow.Range("A1").Resize(1, N_col) = Sheets("数据").Range("A" & i).Resize(1, N_col).Value 'range(A1).Resize(1,3)1表示单行，3表示A1：C1
    If Sheets("数据").Range("B" & i) <> "" Then
    ActiveCell.EntireRow.Range("B1") = Sheets("数据").Range("B" & i)
    End If
    If Sheets("数据").Range("C" & i) <> "" Then
    ActiveCell.EntireRow.Range("F1") = Sheets("数据").Range("C" & i)
    End If
End Sub

3.3 具体实例请下载文本所附资源