Excel快捷输入逐步自动提示

Excel快捷输入逐步自动提示-首字拼音提示

A,C列智能匹配名单表，可首字母拼音也可汉字匹配，根据输入项逐字匹配,可上下方向键选择项目,回车或者双击列表项目输入当前选择项，按下CTRL+E切换是否启用辅助输入，关闭辅助输入时可进行常规复制粘贴

   

  

Excel快捷输入逐步自动提示-详细操作动画

  

Excel快捷输入逐步自动提示-详细VBA代码：

工作表代码：

'------------逐步输入提示--------作者：百度不到去谷歌 QQ80871835----2014/04/09-----------------------------------

' 功能: 逐步输入提示,可首字母拼音提示

' 说明: 自己表导入M输入提示模块和名单表，然后在需要用的表粘贴本模块代码

'       一般来说只需要整理好名单列表,然后修改RangeAddress区域范围即可

'-----------------------------------------------------------------------------------------------------------

Dim txt$ '检测文本框变化

Const RangeAddress = "A2:A65536,C2:C65536" '作用范围,自己修改

'一般来说只需要整理好名单列表,然后修改RangeAddress区域范围即可

Private Sub Worksheet_SelectionChange(ByVal Target As Range) '选择改变时改变菜单位置

    Select Case userinput

    Case False '列表输入状态

        Call 适配(Target, RangeAddress) '第二参数为使用自动提示的单元格区域范围

    Case Else

        '普通输入状态 可复制粘贴,也可自己添加其他输入状态

    End Select

End Sub

'根据列表得到匹配项目,该过程可自己修改为其他规则

Private Sub 智能匹配()

    Dim s, selectFlag

    s = UCase(TextBox1.Text) '拼音

    ListBox1.Clear: selectFlag = True

    '先查拼音是否存在 再查汉字,都不存在则返回全部

    arr = SqlToArr("select 关键字 from [名单$] where 拼音 like '" & s & "%'")

    '--下面一句的全列表查询加不为空的条件

    If TypeName(arr) = "Empty" Then '拼音查不到查汉字

        arr = SqlToArr("select 关键字 from [名单$] where 关键字 like '" & s & "%'")

        If TypeName(arr) = "Empty" Then arr = SqlToArr("select 关键字 from [名单$] where 关键字<>'' "): selectFlag = False

    End If

    ListBox1.List = arr

    If selectFlag Then ListBox1.ListIndex = 0

    'If ListBox1.ListCount = 1 Then TextBox1.Text = ListBox1.List(0, 0)

End Sub

Private Sub 输入()

    If ListBox1.ListIndex = -1 Then '当前输入项无匹配项直接输入

        ActiveCell = TextBox1.Text

    Else '输入当前匹配项

        ActiveCell = ListBox1.Value

    End If

        ActiveCell.Offset(1, 0).Select '完成输入后跳转到下一个单元格

End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    txt = TextBox1 '按键之前输入框文字

End Sub

Private Sub TextBox1_Change() '根据已输入内容查找关键字列表

   Call 智能匹配

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Call 输入

End Sub

'--判断按键,以完成回车输入,上下方向键选择功能,以及ctr+e切换输入状态

Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    Dim i As Integer

    Select Case KeyCode

    Case vbKeyE 'ctr+e切换输入状态

        If Shift = 2 Then Call 输入状态切换

    Case vbKeyDown

        i = ListBox1.ListIndex + 1

        If i < ListBox1.ListCount Then ListBox1.ListIndex = i Else ListBox1.ListIndex = 0

    Case vbKeyUp

        i = ListBox1.ListIndex - 1

        If i > -1 Then ListBox1.ListIndex = i Else ListBox1.ListIndex = ListBox1.ListCount - 1

    Case vbKeyReturn

        If txt = TextBox1 Then Call 输入 '处理中文输入法回车输入英文,不处理会触发回车直接输入英文

    Case Else

        Call 智能匹配

    End Select

    'TextBox1 = ListBox1.Value

End Sub

'调整控件位置和大小以适配当前输入单元格,需要其他显示格式在此处修改

Public Sub 适配(Target As Range, rng$)

    Me.ListBox1.Visible = False

    Me.TextBox1.Visible = False

    If Target.Count = 1 Then

        If 适配范围(Target, rng) Then    '输入提示目标单元格作用范围

            Me.ListBox1.Clear

            Me.TextBox1.Text = ActiveCell.Value    '将活动单元值赋给文本框

            With Me.TextBox1

                .Top = Target.Top

                .Left = Target.Left

                .Width = Target.Width

                .Height = Target.Height + 2

                .Font.Size = Target.Font.Size - 1

                .Activate

                .Visible = True

            End With

            With Me.ListBox1

                .Top = Target.Top + Target.Height

                .Left = Target.Left

                .Width = Target.Width

                .Font.Size = Target.Font.Size

                .Height = Target.Height * 10

                .Visible = True

            End With

            Call 智能匹配

        Else

            Me.ListBox1.Clear

            Me.TextBox1 = ""

            Me.ListBox1.Visible = False

            Me.TextBox1.Visible = False

        End If

    End If

End Sub

Private Function 适配范围(Target As Range, rng$)

'对taget和限制区域求交集,无交集则返回false

'也可以在这里设置其他类型范围限制

    适配范围 = True

    If Intersect(Target, Range(rng)) Is Nothing Then 适配范围 = False

End Function

模块代码：

Option Compare Text

Public userinput As Boolean

Function PY(ByVal rng As Range) '首字母拼音

    Dim i%, k%, str$

    str = Replace(Replace(rng, " ", ""), "　", "")

    For i = 1 To Len(str)

        k = 1

        Do Until Mid("八嚓哒妸发旮铪讥讥咔垃妈拿哦妑七然仨他哇哇哇夕丫匝咗", k, 1) > Mid(str, i, 1)

            k = k + 1

        Loop

        PY = PY & Chr(64 + k)

    Next

End Function

Function SqlToArr(sql$)    '查询结果到数组

    Dim cnn As Object    'New ADODB.Connection

    Dim rs As Object, arr   'New ADODB.Recordset

    Set cnn = CreateObject("adodb.connection")

    cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0';Data Source =" & ThisWorkbook.FullName

    On Error Resume Next

    Set rs = cnn.Execute(sql)

    SqlToArr = Application.Transpose(rs.GetRows) '转置为excle格式的行列

    'Set cnn = Nothing: Set rs = Nothing

End Function

Private Sub test()

    Dim a, s As Boolean

    ss = Not ss

    Debug.Print ss

    a = SqlToArr("select * from [名单$]")

End Sub

Sub 输入状态切换()

' 输入状态切换 Macro

' 切换辅助输入状态 在列表输入和自由输入之间切换

' 快捷键: Ctrl+e

    userinput = Not userinput

    If userinput Then

        s = "关闭列表辅助输入状态!"

        Sheet3.TextBox1.Visible = False

        Sheet3.ListBox1.Visible = False

    Else

        s = "打开列表辅助输入状态!"

    End If

    MsgBox s

End Sub

Public Sub 初始化切换按键()

    On Error Resume Next

    Application.MacroOptions Macro:="输入状态切换", Description:="切换输入形式", ShortcutKey:="e"

End Sub