作者: 百度不到去谷歌
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