Filter a list as the user is typing

[Jonathan Harrison]

My worksheet has a list of names beginning in cell A3 and continuing down in column A. I would like to filter this list based on the value of cell A1 while the user is still typing in A1. For example, when the user types “h” into cell A1, all names that do not begin with “h” will be hidden. I want to accomplish this without the user needing to hit enter.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
I am confident that I can do all of this, I just need to know what the magic line of VBA is that will listen for changes in A1 and execute my script based on the new value of A1, prior to pressing enter.
<o> </o>
Thanks!

 

[jasonb75]

I just need to know what the magic line of VBA is that will listen for changes in A1 and execute my script based on the new value of A1, prior to pressing enter.

That would be a very useful line of code, problem is, I don't think anyone has found it yet.

The known methods require the cell to be closed by pressing enter, or use of a similar action, in order for the procedure to execute.

 

[gregtx81]

Here's a little work-around that utilizes the TextBox Change Event. Basically, whenever A1 is selected, a textbox gets activated (the textbox is a size=0, so it's invisible). Upon typing after the selection of A1, the user is actually typing within the invisible textbox, which is instantaneously updating A1, which triggers a worksheet change event which calls the filter.



The following goes in Module1 and is to be run only once with the sheet you want the filter on being active.

Public Const celltolink = "$A$1"

Sub AddTextBoxZeroSize()

'ThisWorkbook.ActiveSheet.OLEObjects("TextBox1").Delete

With ThisWorkbook.ActiveSheet
        .OLEObjects.Add(ClassType:="Forms.TextBox.1").Name = "TextBox1"
        .OLEObjects("TextBox1").Left = 0
        .OLEObjects("TextBox1").Top = 0
        .OLEObjects("TextBox1").Width = 0
        .OLEObjects("TextBox1").Height = 0
        .OLEObjects("TextBox1").LinkedCell = celltolink

End With

MsgBox "TextBox has been added."
End Sub



Public Sub exitTB(ByVal r As Range, shtnum As Integer)
    Sheets(shtnum).Activate
    r.Select
End Sub

And this is to go in the worksheet module of the sheet your filtering is to be done.

Private gf As Boolean   'textbox1 got focus

Private Sub TextBox1_GotFocus()
    gf = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = Module1.celltolink Then
        TextBox1.Activate
    End If
End Sub


Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    On Error Resume Next    'to ignore error and do nothing when attempt to move active cell off sheet
    Dim rcelltolink As Range
    Set rcelltolink = ActiveSheet.Range(Module1.celltolink)

    Select Case KeyCode

    Case vbKeyReturn, vbKeyEscape, vbKeyDown
            Call exitTB(rcelltolink.Offset(1), ActiveSheet.Index)
    Case vbKeyTab, vbKeyRight
            Call exitTB(rcelltolink.Offset(, 1), ActiveSheet.Index)
    Case vbKeyUp
            Call exitTB(rcelltolink.Offset(-1), ActiveSheet.Index)
    Case vbKeyLeft
            Call exitTB(rcelltolink.Offset(, -1), ActiveSheet.Index)
    Case vbKeyDelete
        TextBox1.Value = ""

    End Select

End Sub


Private Sub TextBox1_Change()
    If gf Then
        gf = False
        TextBox1.Value = Right(TextBox1.Value, 1)
    End If
    updateFilter (TextBox1.Value)
End Sub


Private Sub updateFilter(Str)
    If Len(Str) > 0 Then
        With ThisWorkbook
            .ActiveSheet.Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:="=" & Str & "*"
        End With
    Else: removeFilter
    End If
End Sub

Private Sub removeFilter()
        With ThisWorkbook
            ActiveSheet.AutoFilterMode = False
        End With
End Sub

 

[Jonathan Harrison]

gregtx81, nice workaround. Thanks!

As a note for others, this only works in realtime if A1 is selected via keyboard. Clicking on the cell doesn't seem to work. I haven't looked at the code closely enough to know if there is a simple fix for this or not, but it doesn't really matter.

 

[gregtx81]

Thanks for the feedback Jonathan.

I found two mouse-click related issues that may have been causing problems--clicking A1 when it was already selected (removes textbox focus, yet doesn't create a selection change event) and the double-clicking of A1 (at any time). I hopefully fixed those issues. A remaining bug is when A1 is already selected when the workbook is opened.

Also a correction to my original blurb--- the code, in fact, does not utilize a worksheet change event (although it could with no functional change).

Private gf As Boolean   'textbox1 gained focus--delete prior textbox value upon typing
Private ignoreChangeFocus As Boolean    'if true, overrides above...allows appending to textbox values on a doubleclick as well as accounting
                                        'for focusing on A1 when already selected but was out of focus (textbox_lostfocus but no worksheet_selectionchange)

                                        

Private Sub TextBox1_GotFocus()
    gf = False
    If ignoreChangeFocus = False Then gf = True
    ignoreChangeFocus = False
    
End Sub

Private Sub TextBox1_LostFocus()
    If Selection.Address = Module1.celltolink Then 'when clicking on A1 when it was out of focus but still selected
        ignoreChangeFocus = True
        TextBox1.Activate
        TextBox1.Value = ActiveSheet.Range(Module1.celltolink).Value
    End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = False      'maintain default
    If Target.Address = Module1.celltolink Then
        Cancel = True
        ignoreChangeFocus = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = Module1.celltolink Then
        TextBox1.Activate
    End If
End Sub



Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    On Error Resume Next    'to ignore error and do nothing when attempt to move active cell off sheet
    Dim rcelltolink As Range
    Set rcelltolink = ActiveSheet.Range(Module1.celltolink)

    Select Case KeyCode

    Case vbKeyReturn, vbKeyEscape, vbKeyDown
            Call exitTB(rcelltolink.Offset(1), ActiveSheet.Index)
    Case vbKeyTab, vbKeyRight
            Call exitTB(rcelltolink.Offset(, 1), ActiveSheet.Index)
    Case vbKeyUp
            Call exitTB(rcelltolink.Offset(-1), ActiveSheet.Index)
    Case vbKeyLeft
            Call exitTB(rcelltolink.Offset(, -1), ActiveSheet.Index)
    Case vbKeyDelete
        TextBox1.Value = ""

    End Select

End Sub

Private Sub TextBox1_Change()
    If gf Then
        gf = False
        TextBox1.Value = Right(TextBox1.Value, 1)
    End If
    updateFilter (TextBox1.Value)
End Sub

Private Sub updateFilter(Str)
    If Len(Str) > 0 Then
        With ThisWorkbook
            .ActiveSheet.Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=1, Criteria1:="=" & Str & "*"
        End With
    Else: removeFilter
    End If
End Sub

Private Sub removeFilter()
        With ThisWorkbook
            ActiveSheet.AutoFilterMode = False
        End With
End Sub