Allow Typing-in names much faster

S

south0085

Board Regular
Joined
Aug 15, 2011
Messages
141
Thank you for your time. I'm using Excel 2010.

In a particular cell, the operator types the supplier name. In an adjacent cell, the supplier number populates (vlookup).

In the supplier name cell, I would like for the operater to type the first letter(s) of the supplier name, and the drop down list (or another feature??) to automatically scroll to that letter in the drop down list. Currently, the operator has to scroll very carefully through the drop down until they find the supplier name that they are looking for. This wastes a lot of time.

Or it would be great if: as you typed the letters of the supplier name, it eventually just popped up with that supplier name.

Is something like this possible in Excel?

Thank you.
 
Sort by date Sort by votes
Hi,

Thanks for the code Jaafar, it works great.

Another question, would it be easy to extend this code so it would work on multiple input cells instead of one?
The idea is to select names\items in multiple cells from a huge range that updates itself so you cannot pick the same name\item twice. It would be nice to be able to type some letters like this instead of scrolling down to find everything.

Cheers
 
Upvote 0

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Hi urdus,
Welcome to the board
Does the data source range stay the same or does it change ? Are we talking about one worksheet ? ie: data source and input cells are all in the same worksheet
 
Upvote 0
Thanks! Right now the input cell(s) and the source range is in two different sheets, but your code still works fine by changing Private Const ListRangeAddr As String = "A7:A15000" to "Private Const ListRangeAddr As String = "Sheet2!C1:C500". The source will always be C1:C500, but the values in it changes as it removes the names\items that's already taken in another input cell from sheet1 and sort it again so the empty cell is last.
 
Last edited:
Upvote 0
See if this works for you : (I defined a const InputCells which you can adapt to your needs)

Code in Thisworkbook module:
Code: 
Option Explicit
Private WithEvents txtbx As MSForms.TextBox
Private WithEvents LB As MSForms.ListBox
[B][COLOR=#008000]
'change these Constantes to meet your data layout[/COLOR][/B]
[COLOR=#ff0000][B]Private Const SheetName As String = "Sheet1"
Private Const ListRangeAddr As String = "A7:A15000"
Private Const InputCells As String = "E6,E14,G6,G14"[/B][/COLOR]

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
    Names("CurInputCell").Delete
    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([CurInputCell]).Address Then
        With Range([CurInputCell])
            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([CurInputCell]) = 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([CurInputCell]) = 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([CurInputCell]) = .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([CurInputCell])
        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)
    Dim lIndex As Long
    On Error Resume Next
    If Sh.Name = SheetName Then
    lIndex = WorksheetFunction.Match(Target.Address(False, False), Split(InputCells, ","), 0)
      If lIndex Then
            Names.Add "CurInputCell", Target.Address(False, False)
            Application.OnKey "{F1}", Me.CodeName & ".BringupList"
        Else
            Application.OnKey "{F1}", ""
            Sh.OLEObjects("MyTextBox").Delete
            Sh.OLEObjects("MyListBox").Delete
        End If
    End If
End Sub
 
Upvote 0
Ignore the previous code and use this one which takes into account the unlikely scenario where the user selects an input cell while another input cell is still displaying the Dropdown list :

Fresh Workbook download example

Code: 
Option Explicit
Private WithEvents txtbx As MSForms.TextBox
Private WithEvents LB As MSForms.ListBox

[B][COLOR=#008000]'change these Constantes to meet your data layout[/COLOR][/B]
Private Const SheetName As String = "Sheet1"
Private Const ListRangeAddr As String = "A7:A15000"
Private Const InputCells As String = "E6,E14,G6,G14"

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
    Names("CurInputCell").Delete
    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([CurInputCell]).Address Then
        With Range([CurInputCell])
            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([CurInputCell]) = 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([CurInputCell]) = 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([CurInputCell]) = .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([CurInputCell])
        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)
    Dim lIndex As Long
    On Error Resume Next
    If Sh.Name = SheetName Then
        lIndex = WorksheetFunction.Match(Target.Address(False, False), Split(InputCells, ","), 0)
        If lIndex And Target.Cells.Count = 1 Then
            Sh.OLEObjects("MyTextBox").Delete
            Sh.OLEObjects("MyListBox").Delete
            Names.Add "CurInputCell", Target.Address(False, False)
            Application.OnKey "{F1}", Me.CodeName & ".BringupList"
        Else
            Application.OnKey "{F1}", ""
            Sh.OLEObjects("MyTextBox").Delete
            Sh.OLEObjects("MyListBox").Delete
        End If
    End If
End Sub
 
Last edited:
Upvote 0
UPDATE ... For when the LIST and the DV Input Cells are located each on a seperate worksheet.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Edit VBA To Be Faster / Stop Excel Crashing
Replies
7
Views
439
johnnyL
J
C
  • Question
Dependent Drop Down Help, Excel 2010
Replies
5
Views
149
Akuini
Akuini
I
  • Solved
Dynamic Named Ranges with Data Validation
Replies
7
Views
143
kevin9999
K
K
  • Question
Looking to create a drop-down list where selecting a name brings me to a specific cell containing that name
Replies
5
Views
103
SanjayGMusafir
SanjayGMusafir
JeffGrant
  • Question
Splitting from Outlook Email Body
2
Replies
12
Views
495
Kerryx
K

Forum statistics

Threads
1,215,003
Messages
6,122,655
Members
449,091
Latest member
peppernaut

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top