'Code written by jaafar tribak on 29/04/2015
'This code adds a custom validation list to a worksheet cell
'The list is dynamically filtered down to the entries that begin with the first typed letters
'This speeds up data entry enormously ! Ideal for data entry from long lists
'The code uses a textbox and a listbox both added @ runtime
'Steps to bring up the validation list :
'=========================
'- Select the input cell (in this example Cell (E6))
'- Press the (F1) key to display the list
'- Press the (ESC) key or deselect the input cell to dismiss the list
'This code requires a reference to the MSFORMS library
'You can just add a temporary dummy userform to the vb project and then delete it
'Code written and tested on Win XP - Excel 2007
'Thanks to Kyle123 @ MrExcel.com for assissiting with the Filter function
Option Explicit
Private WithEvents txtbx As MSForms.TextBox
Private WithEvents LB As MSForms.ListBox
'change these Constantes to meet your data layout
Private Const SheetName As String = "Sheet1"
Private Const ListRangeAddr As String = "A7:A15000"
Private Const InputCellAddr As String = "E6"
Private Sub Workbook_Open()
Application.OnKey "{F1}", Me.CodeName & ".BringupList"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "{F1}", ""
On Error Resume Next
Sheets(SheetName).OLEObjects("MyListBox").Delete
Sheets(SheetName).OLEObjects("MyTextBox").Delete
End Sub
Private Sub BringupList()
Dim oTxtBx As OLEObject
Dim oLbx As OLEObject
If ActiveCell.Address = Range(InputCellAddr).Address Then
With Range(InputCellAddr)
Set oTxtBx = Sheets(SheetName).OLEObjects.Add(ClassType:="Forms.TextBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=.Left, Top:=.Top, Width:=.Width, Height _
:=.Height)
End With
oTxtBx.Name = "MyTextBox"
Set oLbx = Sheets(SheetName).OLEObjects.Add(ClassType:="Forms.ListBox.1")
oLbx.Name = "MyListBox"
Application.OnTime Now, Me.CodeName & ".HookAndBuildControls"
End If
End Sub
Private Sub LB_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Static lastIndex As Long
With Sheets(SheetName)
If KeyCode = vbKeyEscape Then
.OLEObjects("MyTextBox").Delete
.OLEObjects("MyListBox").Delete
Exit Sub
End If
If KeyCode = vbKeyUp And LB.ListIndex = 0 And lastIndex <> 1 Or LB.ListCount = 0 Then
LB.ListIndex = -1
.OLEObjects("MyTextBox").Activate
txtbx.Text = "": Exit Sub
End If
End With
txtbx.Text = LB.Text
lastIndex = LB.ListIndex
End Sub
Private Sub LB_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
On Error Resume Next
Range(InputCellAddr) = LB.Value
Sheets(SheetName).OLEObjects("MyTextBox").Delete
Sheets(SheetName).OLEObjects("MyListBox").Delete
End Sub
Private Sub LB_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
With Sheets(SheetName)
If KeyCode = VBA.vbKeyEscape Then
.OLEObjects("MyTextBox").Delete
.OLEObjects("MyListBox").Delete
Exit Sub
End If
If KeyCode = vbKeyReturn Then
Range(InputCellAddr) = LB.Value
.OLEObjects("MyTextBox").Delete
.OLEObjects("MyListBox").Delete
Exit Sub
End If
End With
End Sub
Private Sub txtbx_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim indx As Long
Dim ar() As Variant
On Error Resume Next
Select Case KeyCode
Case vbKeyDown
LB.Selected(0) = True
Sheets(SheetName).OLEObjects("MyListBox").Activate
Exit Sub
Case vbKeyUp
Exit Sub
Case vbKeyEscape
Sheets(SheetName).OLEObjects("MyTextBox").Delete
Sheets(SheetName).OLEObjects("MyListBox").Delete
Exit Sub
Case vbKeyReturn
With txtbx
indx = WorksheetFunction.Match(.Text, Application.Transpose(Range(ListRangeAddr)), 0)
If indx = 0 Then
MsgBox "Invalid input" & vbCrLf & "Try Again ", vbCritical
.SelStart = 0
.SelLength = Len(.Text)
Else
Range(InputCellAddr) = .Text
Sheets(SheetName).OLEObjects("MyTextBox").Delete
Sheets(SheetName).OLEObjects("MyListBox").Delete
Exit Sub
End If
End With
Case VBA.vbKeyBack
End Select
Application.OnTime Now, Me.CodeName & ".FilterList"
End Sub
Private Sub FilterList()
On Error Resume Next
Dim i As Long
Dim ar() As Variant
Dim resultString As String
Dim delim As String: delim = Chr(1)
ar = Application.Transpose(Range(ListRangeAddr))
With LB
ar(1) = Chr(2) & delim & ar(1)
resultString = Join(Filter(Split("|" & Join(ar, Chr(2) & delim), Chr(2)), delim & txtbx.Text, compare:=vbTextCompare), "")
If Len(resultString) <> 0 Then
.List = Split(Right(resultString, Len(resultString) - 1), delim)
Else
.Clear
End If
.IntegralHeight = False
.Height = .Height
.IntegralHeight = True
End With
End Sub
Private Sub HookAndBuildControls()
Dim oCell As Range
Dim ar() As Variant
Set txtbx = Sheets(SheetName).OLEObjects("MyTextBox").Object
With txtbx
.SpecialEffect = fmSpecialEffectFlat
.BackColor = &H80FFFF
.BorderStyle = fmBorderStyleSingle
.ForeColor = vbRed
.Font.Bold = True
End With
Set LB = Sheets(SheetName).OLEObjects("MyListBox").Object
With Range(InputCellAddr)
LB.Left = .Left
LB.Top = .Offset(1).Top + 1
LB.Height = 200
LB.Width = .Width + 12
End With
With LB
.SpecialEffect = fmSpecialEffectFlat
.BackColor = &H80FFFF
.BorderStyle = fmBorderStyleSingle
.IntegralHeight = False
.Height = .Height
.IntegralHeight = True
End With
ar = Application.Transpose(Range(ListRangeAddr))
LB.List = ar
Sheets(SheetName).OLEObjects("MyListBox").Visible = False
Sheets(SheetName).OLEObjects("MyListBox").Visible = True
txtbx.Activate
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = SheetName Then
Application.OnKey "{F1}", Me.CodeName & ".BringupList"
End If
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Sh.Name = SheetName Then
Application.OnKey "{F1}", ""
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If Sh.Name = SheetName Then
If Target.Address = Range(InputCellAddr).Address Then
Application.OnKey "{F1}", Me.CodeName & ".BringupList"
Else
Application.OnKey "{F1}", ""
Sh.OLEObjects("MyTextBox").Delete
Sh.OLEObjects("MyListBox").Delete
End If
End If
End Sub
