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

作者:  百度不到去谷歌  Excel快捷输入逐步自动提示-首字拼音提示A,C列智能匹配名单表，可首字母拼音也可汉字匹配，根据输入项逐字匹配,可上下方向键选择项目,回车或者双击列表项目输入当前选择项，按下CTRL+E切换是否启用辅助输入，关闭辅助输入时可进行常规复制粘贴

1481637496576195.jpg

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

1481637939648962.gif

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 SelectEnd 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  -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.ValueEnd 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 IfEnd Sub
Private Function 适配范围(Target As Range, rng$) '对taget和限制区域求交集,无交集则返回false '也可以在这里设置其他类型范围限制  适配范围 = True  If Intersect(Target, Range(rng)) Is Nothing Then 适配范围 = FalseEnd Function
模块代码：
Option Compare TextPublic userinput As BooleanFunction 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)  NextEnd FunctionFunction 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 = NothingEnd Function
Private Sub test()  Dim a, s As Boolean  ss = Not ss  Debug.Print ss  a = SqlToArr("select * from [名单$]")End SubSub 输入状态切换() ' 输入状态切换 Macro ' 切换辅助输入状态 在列表输入和自由输入之间切换 ' 快捷键: Ctrl+e  userinput = Not userinput  If userinput Then    s = "关闭列表辅助输入状态!"    Sheet3.TextBox1.Visible = False    Sheet3.ListBox1.Visible = False  Else    s = "打开列表辅助输入状态!"  End If  MsgBox sEnd SubPublic Sub 初始化切换按键()  On Error Resume Next  Application.MacroOptions Macro:="输入状态切换", Description:="切换输入形式", ShortcutKey:="e"End Sub