【20180309】- Excel VBA智能提示,，實現(xiàn)快速輸入

L羅樂 2018-03-09

展開全文

剛剛過去的女神節(jié)和女王節(jié)，各位女王讀者是否紅包收到手軟,，買東西買到手軟,？在享受購買的同時，也不要忘記投資自己,，不斷學習提高哦,。

今天為大家?guī)淼氖?strong>Excel智能提示，那智能提示有啥用呢,？可以避免輸入錯誤,，實現(xiàn)快速數(shù)據(jù)錄入。最終的效果如下動態(tài)圖演示：

看了上面的效果展示,，可以看到【錄入表】中的姓名列點擊的時候可以出現(xiàn)下拉框選擇,，可以實現(xiàn)快速鼠標點選或直接Enter回車確定錄入。如果覺得下拉框內容太多,，可以輸入【信息表】中的拼音首字母或姓名的某個字,。那信息表長什么樣呢,？如下圖所示：

正如上圖中青色方塊中的說明，拼音列中的拼音是使用HzToPy函數(shù)根據(jù)姓名生成的,。其中B2單元格的公式為：=UPPER(HzToPy(A2,'',0,1,1)),，這里用到了自定義函數(shù)HzToPy。該類模塊來源于互聯(lián)網(wǎng),，詳細的使用方法請參考【HzToPy】工作表,。

上面介紹的智能錄入，我在好幾個Excel財務軟件中看到類似的實現(xiàn),，對于會計憑證等的錄入是很方便的,。智能提示的代碼主要集中在【錄入表】和模塊【智能提示】中。

代碼很長,，我會在文章的最后貼上核心代碼,。其實代碼的核心就是如何實現(xiàn)Textbox和Listbox的隱藏和內容。Textbox和Listbox的內容又是通過先前為大家介紹的Excel Sql實現(xiàn),，可以移步【VBA技巧】- 從Excel文件或Access數(shù)據(jù)庫中獲取指定列數(shù)據(jù)進行學習,。主要用到的語句類似arr = SqlToArr('select 姓名 from [信息表$] where 姓名 like '%' & s & '%'')，其實也就是select配合like實現(xiàn)模糊查詢,。

上面的代碼稍作了修改,，如果各位小伙伴需要用到自己的實際工作中，只需要修改select查詢部分即可,，是不是很Easy呢,？

可能有小伙伴就要問了，那代碼是如何決定智能提示的區(qū)域的呢,？這個問題很好,，其實代碼有一個全局常量RangeAddress就是智能提示的作用范圍，可以根據(jù)需要進行修改,，如下圖紅色框中所示,。

核心代碼：
Dim txt$ '檢測文本框變化
Const RangeAddress = 'B5:B30' '作用范圍,自己修改

'一般來說只需要整理好成品基礎資料列表,然后修改RangeAddress區(qū)域范圍即可
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '選擇改變時改變菜單位置
Select Case userinput
Case False '列表輸入狀態(tài)
Call 適配(Target, RangeAddress) '第二參數(shù)為使用自動提示的單元格區(qū)域范圍
Case Else
'普通輸入狀態(tài) 可復制粘貼,也可自己添加其他輸入狀態(tài)
End Select

End Sub

'根據(jù)列表得到匹配項目,該過程可自己修改為其他規(guī)則
Private Sub 智能匹配()
Dim s, selectFlag
s = UCase(TextBox1.Text) '輸入的姓名或拼音
ListBox1.Clear: selectFlag = True
If s = '' Or s = ' ' Then
arr = SqlToArr('select 姓名 from [信息表$] where 姓名<>'''): selectFlag = False
Else
'先查拼音是否存在再查姓名,都不存在則返回全部
arr = SqlToArr('select 姓名 from [信息表$] where 拼音 like '%' & s & '%'')
'--下面一句的全列表查詢加不為空的條件
If TypeName(arr) = 'Empty' Then '拼音查不到查姓名
arr = SqlToArr('select 姓名 from [信息表$] where 姓名 like '%' & s & '%'')
End If
End If

If TypeName(arr) = 'Empty' Then Exit Sub
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() '根據(jù)已輸入內容查找編碼列表
Call 智能匹配
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call 輸入
End Sub

'--判斷按鍵,以完成回車輸入,上下方向鍵選擇功能,以及ctr e切換輸入狀態(tài)
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim i As Integer
Select Case KeyCode
Case vbKeyE 'ctr e切換輸入狀態(tài)
If Shift = 2 Then Call 輸入狀態(tài)切換
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 輸入 '處理中文輸入法回車輸入英文,不處理會觸發(fā)回車直接輸入英文
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和限制區(qū)域求交集,無交集則返回false
'也可以在這里設置其他類型范圍限制
適配范圍 = True
If Intersect(Target, Range(rng)) Is Nothing Then 適配范圍 = False
End Function