Drop down menu to work like google search

[pantakos]

Hello,

I have the following code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim bottomC As Long
    bottomC = Sheets("DATA").Range("C" & Rows.Count).End(xlUp).Row
    Dim x As Long
    For x = bottomC To 2 Step -1
        If Sheets("DATA").Cells(x, 1) = Target Then
            Sheets("DATA").Cells(x, 3).Copy Cells(Target.Row + 4, Target.Row)
           Sheets("DATA").Cells(x, 4).Copy Cells(Target.Row + 5, Target.Row)
            Sheets("DATA").Cells(x, 5).Copy Cells(Target.Row + 2, Target.Row)
            Sheets("DATA").Cells(x, 6).Copy Cells(Target.Row + 3, Target.Row)
           Sheets("DATA").Cells(x, 10).Copy Cells(Target.Row + 6, Target.Row)
           Sheets("DATA").Cells(x, 9).Copy Cells(Target.Row + 7, Target.Row)
           Sheets("DATA").Cells(x, 14).Copy Cells(Target.Row + 1, Target.Row)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

I was wondering if it possible to make it work like google search. I mean, like google, when type then make suggestions.

Example sheet

SampleFile

Thank you in advance !

 

[Peter_SSs]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

See if something like this might be of use to you.

 

[pantakos]

@Peter_SSs I did that , changed my account details. I show the link you provided and I cant use that, its a combobox and I cant use.
Thank you for your effort

 

[My Aswer Is This]

@Peter_SSs I did that , changed my account details. I show the link you provided and I cant use that, its a combobox and I cant use.
Thank you for your effort

I looked at your question and did not understand this:
"I was wondering if it possible to make it work like google search. I mean, like google, when type then make suggestions.

 

[Peter_SSs]

I show the link you provided and I cant use that, its a combobox and I cant use.

In that case I don't think that you are going to achieve your desired result. (I would be happy to be proved wrong though.)

Thanks for updating your details though.

 

[Jaafar Tribak]

Hi,

Here a slightly improved version of some code I wrote in the past.

The code filters the list as you type in. It uses two activeX controls (a Textbox and a Listbox ) created on the fly and automatically placed over the data input cell(s)... In order to bring up the doropdown list into view, you need to select the input cell(s) and press the F1 key... You should then be able to edit the input cell and navigate the dropdown list with the mouse as well as with the keyboard as you would expect.

To close the dropdown, simply press the ESC key or unselect the input cell.

I have placed the Target sheet, List source range, Target input cell(s) and dropdown constants at the top of the module for easy use, in case you want to change their values.

Also, you can apply this to multiple input cells.

Workbook Demo for downloading


This is the entire code which goes in the ThisWorkbook Module:

Option Explicit

Private WithEvents txtbx As MSForms.TextBox
Private WithEvents lbx As MSForms.ListBox

'//////////////////////////////////////////////////////////
'Change these Constants to meet your specific needs.
    Private Const SHEET_NAME = "Sheet1"
    Private Const LIST_RANGE_ADDRSS = "A7:A15000"
    Private Const INPUT_CELLS = "E6,E14,G6,G14"
    Private Const DROPDOWN_HEIGHT = 150 'pt
'//////////////////////////////////////////////////////////


'_________________________________________WORKBOOK EVENTS___________________________________________________
Private Sub Workbook_Activate()
    Call AddNameAndBringUpList(ByVal ActiveSheet, ByVal ActiveCell)
    Application.OnKey "{F1}", Me.CodeName & ".BringupList"
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = SHEET_NAME Then
        Application.OnKey "{F1}", Me.CodeName & ".BringupList"
    End If
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    If Sh.Name = SHEET_NAME Then
        Application.OnKey "{F1}", ""
    End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call AddNameAndBringUpList(ByVal Sh, ByVal Target)
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = SHEET_NAME Then
        If IsError(Application.Match(Target, Range(LIST_RANGE_ADDRSS), 0)) And Not IsEmpty(Target) Then
            MsgBox "Entry not in the list." & vbCrLf & vbCrLf & "Try Again ", vbCritical, "Invalid Input."
            Target.Select
            Target.ClearContents
        End If
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnKey "{F1}", ""
    On Error Resume Next
    Names("CurInputCell").Delete
    Sheets(SHEET_NAME).OLEObjects("MyListBox").Delete
    Sheets(SHEET_NAME).OLEObjects("MyTextBox").Delete
End Sub


'_________________________________________LISTBOX & TEXTBOX EVENTS___________________________________________________
Private Sub lbx_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Static lastIndex As Long
 
    With Sheets(SHEET_NAME)
        If KeyCode = vbKeyEscape Then
            .OLEObjects("MyTextBox").Delete
            .OLEObjects("MyListBox").Delete
            Exit Sub
        End If
        If KeyCode = vbKeyUp And lbx.ListIndex = 0 And lastIndex <> 1 Or lbx.ListCount = 0 Then
            lbx.ListIndex = -1
            .OLEObjects("MyTextBox").Activate
            txtbx.Text = "": Exit Sub
        End If
    End With
    txtbx.Text = lbx.Text
    lastIndex = lbx.ListIndex
End Sub

Private Sub lbx_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    On Error Resume Next
    Range([CurInputCell]) = lbx.Value
    Sheets(SHEET_NAME).OLEObjects("MyTextBox").Delete
    Sheets(SHEET_NAME).OLEObjects("MyListBox").Delete
End Sub

Private Sub lbx_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    With Sheets(SHEET_NAME)
        If KeyCode = VBA.vbKeyEscape Then
            .OLEObjects("MyTextBox").Delete
            .OLEObjects("MyListBox").Delete
            Exit Sub
        End If
        If KeyCode = vbKeyReturn Then
            Range([CurInputCell]) = lbx.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
            lbx.Selected(0) = True
            Sheets(SHEET_NAME).OLEObjects("MyListBox").Activate
            Exit Sub
        Case vbKeyUp
            Exit Sub
        Case vbKeyEscape
            Sheets(SHEET_NAME).OLEObjects("MyTextBox").Delete
            Sheets(SHEET_NAME).OLEObjects("MyListBox").Delete
            Exit Sub
        Case vbKeyReturn
            With txtbx
            indx = WorksheetFunction.Match(.Text, Application.Transpose(Range(LIST_RANGE_ADDRSS)), 0)
            If indx = 0 Then
                MsgBox "Entry not in the list." & vbCrLf & vbCrLf & "Try Again ", vbCritical, "Invalid Input."
                .SelStart = 0
                .SelLength = Len(.Text)
            Else
                Range([CurInputCell]) = .Text
                Sheets(SHEET_NAME).OLEObjects("MyTextBox").Delete
                Sheets(SHEET_NAME).OLEObjects("MyListBox").Delete
                Exit Sub
            End If
            End With
        Case VBA.vbKeyBack
    End Select
    Application.OnTime Now, Me.CodeName & ".FilterList"
End Sub


'__________________________________________HELPER ROUTINES________________________________________________
Private Sub AddNameAndBringUpList(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    If Sh.Name = SHEET_NAME Then
        If Not IsError(Application.Match(Target.Address(False, False), Split(INPUT_CELLS, ","), 0)) Then
            If Target.Cells.Count = 1 Then
                Sh.OLEObjects("MyTextBox").Delete
                Sh.OLEObjects("MyListBox").Delete
                Names.Add "CurInputCell", Target.Address(False, False), False
                Application.OnKey "{F1}", Me.CodeName & ".BringupList"
                End If
            Else
                Application.OnKey "{F1}", ""
                Sh.OLEObjects("MyTextBox").Delete
                Sh.OLEObjects("MyListBox").Delete
        End If
    End If
End Sub

Private Sub HookAndBuildControls()
    Dim oCell As Range
    Dim ar() As Variant
 
    On Error Resume Next
    Set txtbx = Sheets(SHEET_NAME).OLEObjects("MyTextBox").Object
    With txtbx
        .SpecialEffect = fmSpecialEffectFlat
        .BackColor = &HC0FFFF    ' &H80FFFF
        .BorderStyle = fmBorderStyleSingle
        .ForeColor = vbRed
        .Font.Bold = True
    End With
    Set lbx = Sheets(SHEET_NAME).OLEObjects("MyListBox").Object
    With Range([CurInputCell])
        lbx.Left = .Left
        lbx.Top = .Offset(1).Top + 1
        lbx.Height = DROPDOWN_HEIGHT
        lbx.Width = .Width + 12
    End With
    With lbx
        .SpecialEffect = fmSpecialEffectFlat
        .BackColor = &HC0FFFF '&H80FFFF
        .BorderStyle = fmBorderStyleSingle
        .IntegralHeight = False
        .Height = .Height
        .IntegralHeight = True
    End With
    ar = Application.Transpose(Range(LIST_RANGE_ADDRSS))
    lbx.List = ar
    Sheets(SHEET_NAME).OLEObjects("MyListBox").Visible = False
    Sheets(SHEET_NAME).OLEObjects("MyListBox").Visible = True
    txtbx.Activate
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(LIST_RANGE_ADDRSS))
    With lbx
        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 BringupList()
    Dim oTxtBx As OLEObject
    Dim oLbx As OLEObject
 
    If Not IsError(Application.Match(ActiveCell.Address(False, False), Split(INPUT_CELLS, ","), 0)) Then
        If ActiveCell.Address = Range([CurInputCell]).Address Then
            With Range([CurInputCell])
                Set oTxtBx = Sheets(SHEET_NAME).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(SHEET_NAME).OLEObjects.Add(ClassType:="Forms.ListBox.1")
            oLbx.Name = "MyListBox"
            Application.OnTime Now, Me.CodeName & ".HookAndBuildControls"
        End If
    End If
End Sub

In the uploaded workbook example, the code searches a list of 5000 entries and seems to work fast enough when tested.

I hope you find this useful.

 

[Jaafar Tribak]

A small addition to the above code so that the dropdown item that is currently under the mouse is highlighted.

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If


Private Sub lbx_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim oAcc As IAccessible, lPt As POINTAPI
   
    Set oAcc = lbx
    Call GetCursorPos(lPt)
    lbx.ListIndex = CLng(oAcc.accHitTest(lPt.X, lPt.Y)) - 1
End Sub

I have updated the above uploaded workbook example witth this last code addition.