[求助]怎么从下拉菜单中实现快速输入？

Sub bbb()
    Application.EnableEvents = False
    Selection.Value = Application.CommandBars.ActionControl.Caption  把选中值填如目标
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Row < 2 Then Exit Sub
    If Target.Column > 1 Then Exit Sub   3种情况下退出
    vl = Target.Value       取值
    If Len(vl) > 1 Then Exit Sub  多于1个字退出
    Target.Select    回到原单元格
    On Error Resume Next
    Set sj = Worksheets("Sheet2")
    ed = sj.[a65536].End(xlUp).Row
    Set rg = sj.Range("a2:a" & ed).Find(vl, LookIn:=xlValues)   找第一个匹配值
    If rg Is Nothing Then Exit Sub   没有就退出
    With Application.CommandBars.Add(Name:="mycell", Position:=msoBarPopup) 设置菜单
        r0 = 1      已查到行
        r = rg.Row  新查到行
        Do While r > r0   新查到比已查到大就继续
            r0 = r
            With .Controls.Add(Type:=msoControlButton)  设置菜单项
                .Caption = rg.Value   把查到值作为显示值
                .OnAction = "bbb"     如选择此项运行bbb
            End With
            Set rg = sj.Range("a2:a" & ed).FindNext(rg)   找下一个
            If Not rg Is Nothing Then r = rg.Row     如果找到了取新查到行值
        Loop
    End With
    If Application.CommandBars("Mycell").Controls.Count = 1 Then  如果仅查到1项
        Application.EnableEvents = False
        Selection.Value = Application.CommandBars("Mycell").Controls(1).Caption   把值直接填入目标
        Application.EnableEvents = True
    Else
        Application.CommandBars("Mycell").ShowPopup    否则弹出菜单
    End If
    Application.CommandBars("Mycell").Delete   删除菜单
End Sub

这种功能在会计中也经常用到，不知能不能只在输入第一个字后，不用回车，就能达到楼主后说的功能？