【20180309】- Excel VBA智能提示，實現快速輸入

來自專欄 SUT事務所

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

今天為大家帶來的是Excel智能提示，那智能提示有啥用呢？可以避免輸入錯誤，實現快速數據錄入。最終的效果如下動態圖演示：

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

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

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

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

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

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

核心代碼：

Dim txt$ 檢測文本框變化Const RangeAddress = "B5:B30" 作用範圍,自己修改一般來說只需要整理好成品基礎資料列表,然後修改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 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 SubPrivate Sub 輸入() If ListBox1.ListIndex = -1 Then 當前輸入項無匹配項直接輸入 ActiveCell = TextBox1.Text Else 輸入當前匹配項 ActiveCell = ListBox1.Value End If ActiveCell.Offset(1, 0).Select 完成輸入後跳轉到下一個單元格End SubPrivate Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) txt = TextBox1 按鍵之前輸入框文字End SubPrivate Sub TextBox1_Change() 根據已輸入內容查找編碼列表 Call 智能匹配End SubPrivate 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.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 SubPrivate Function 適配範圍(Target As Range, rng$) 對taget和限制區域求交集,無交集則返回false 也可以在這裡設置其他類型範圍限制 適配範圍 = True If Intersect(Target, Range(rng)) Is Nothing Then 適配範圍 = FalseEnd Function

好了，今天的介紹就到這裡了，素材的原稿，我會放到QQ群文件中，大家如果在使用智能提示過程中遇到任何問題，歡迎留言或加入QQ群（群號：615356012）交流學習哦^_^Written by Steven in 20180309^_^

微信公眾號：SaveUTime

SUT學習交流群：615356012，入群審核人：Steven

關注公眾號，提高效率，節約您的時間！