vbauserform

How to keep entered value when its not found in list box


I have some free to use code that is doing a great job and I am trying to make what I consider a small change.

I found this similar question but it seems to be wanting to achieve the opposite results.

Currently the code works great, and generates a filtered list on information typed in. When the filtered list wind up being empty (nothing contains what has been typed in) the message No items found! appears.

I found this section of code in a class module:

' LISTBOX SUBS
Private Sub UpdateListbox(items As Variant)
 
    With myListBox
  
        ' Reload listbox
        .Clear
        .ForeColor = rgbBlack
        
        ' Set the listbox size
        If IsEmpty(items) Then
            ' No items found
            .List = Array("No items found!")
            .ForeColor = rgbRed
        Else
            ' items found
            .List = items
            .ListIndex = 0
        End If
        
        ' Resize the listbox
        Call SetListboxPosition
         
         ' If show all matches then have a scrollbar
        If m_showAllMatches = True Then
            Call MakeAllMatchesAvailable
        Else
            .Height = ResizeListbox(myListBox, myTextBox.Font.Size)
        End If
    
    End With

End Sub

My desired change is to keep the information that has been typed in the corresponding text box as the result instead of changing it to No items found

My userform is called PPT My Text box is called ProjectNoTextBox

Example

If my list of projects is as follows:

1000 - Thousand
2001 - space odessy
3000 - unknown
4321 - countdown

Current behaviour:

I enter `1000 - T` I get the result of `1000 - Thousand`
I enter `9999 - TBD` I get the result of `No items found`

Desired behaviour:

I enter `9999 - TBD` I get the result of `9999 - TBD`

Update

Potential missing code:

This is in the class modules:

Public Event ItemSelected()

Private Const m_conMaxRows As Long = 6

' Configurable Settings
Private m_compareMethod As VbCompareMethod  ' Determines case sensitivity in the search
Private m_listOfItems As Variant            ' This is the array of items that is filtered
Private m_maxRows As Long                   ' The number of rows to be displayed in the listbox.
Private m_startText As String               ' Start text in the textbox
Private m_showAllMatches As Boolean         ' True: shows all matches. False show the number of rows specified by m_MaxRows

' This is used to prevent events running when changes are being made
Private m_UpdateControl As Boolean

Private m_textboxStartingState As Boolean   ' Used to decide when to remove the starting text

Private WithEvents myListBox As MSForms.ListBox
Private WithEvents myTextBox As MSForms.TextBox

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU


' PROPERTIES
Public Property Let CompareMethod(ByVal value As VbCompareMethod)
    m_compareMethod = value
    Call FilterListBox
End Property
Public Property Get SelectedItem() As String
    SelectedItem = IIf(m_textboxStartingState = True, "", myTextBox.value)
End Property
Public Property Let List(ByVal value As Variant)
    m_listOfItems = value
End Property
' The number of rows that will be visible in the listbox
Public Property Let MaxRows(ByVal value As Long)
    m_maxRows = value
    Call FilterListBox
End Property
' Set the text to be displayed in the textbox before the search
Public Property Let StartText(ByVal text As String)
    m_startText = text
    SetTextboxValue (m_startText)
End Property
' If true include all matches in the listbox. If false only show the
' rows specified by m_MaxRows
Public Property Let ShowAllMatches(ByVal state As Boolean)
    m_showAllMatches = state
    Call FilterListBox
End Property

Public Property Set SearchListBox(ByVal oListBox As MSForms.ListBox)
    Set myListBox = oListBox
    Call InitializeListBox
End Property

Public Property Set SearchTextBox(ByVal oTextBox As MSForms.TextBox)
    Set myTextBox = oTextBox
    Call InitializeTextBox
End Property

Public Property Get SearchTextBox() As MSForms.TextBox
    Set SearchTextBox = myTextBox
End Property


' CLASS EVENTS

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
' Description: Set the defaults
Private Sub Class_Initialize()

    Call Reset
    
End Sub

Public Sub Reset()
    m_compareMethod = vbTextCompare
    m_maxRows = m_conMaxRows
    m_startText = "Type the item you wish to search for"
    m_showAllMatches = False
End Sub

' LISTBOX EVENTS

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub myListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    ' If the user clicks or presses enter then
    ' place the selected value in the textbox
    If m_UpdateControl = False Then
        SetTextboxValue myListBox.value
        Call ShowListbox(False)
    End If
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub myListBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    ' When the key is down in the listbox turn on
    ' m_UpdateControl to prevent the click event occurring
    If KeyCode = vbKeyDown Then
        m_UpdateControl = True
    ElseIf KeyCode = vbKeyUp Then
        m_UpdateControl = True
        CheckListBoxFirstItem
   
    ElseIf KeyCode = vbKeyReturn Then
        ' swallow the enter keycode as it passes on to the ok button
        KeyCode = 0
        SetTextboxValue myListBox.value
        Call ShowListbox(False)
    End If
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub myListBox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    ' Turn update control off - turned on in KeyDown
    If KeyCode = vbKeyDown Then
        m_UpdateControl = False
    ElseIf KeyCode = vbKeyUp Then
        m_UpdateControl = False
    ElseIf KeyCode = vbKeyReturn Then
        MsgBox "return key"
    End If
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub List_MoveDown()
    m_UpdateControl = True
    If m_textboxStartingState = False Then
        With myListBox
            .SetFocus
            If .ListIndex < .ListCount - 1 Then
                .ListIndex = .ListIndex + 1
                .Selected(.ListIndex) = True
            End If
        End With
    End If
    m_UpdateControl = False
End Sub


' LISTBOX SUBS
Private Sub UpdateListbox(items As Variant)
 
    With myListBox
  
        ' Reload listbox
        .Clear
        .ForeColor = rgbBlack
        
        ' Set the listbox size
        If IsEmpty(items) Then
            ' No items found
            .List = Array("No items found!")
            .ForeColor = rgbRed
        Else
            ' items found
            .List = items
            .ListIndex = 0
        End If
        
        ' Resize the listbox
        Call SetListboxPosition
         
         ' If show all matches then have a scrollbar
        If m_showAllMatches = True Then
            Call MakeAllMatchesAvailable
        Else
            .Height = ResizeListbox(myListBox, myTextBox.Font.Size)
        End If
    
    End With

End Sub


Private Sub MakeAllMatchesAvailable()

    With myListBox
     
        ' To get the scrollbar working correctly it is necessary to
        ' turn IntegralHeight off and on
        .IntegralHeight = False
        .Height = ResizeListbox(myListBox, myTextBox.Font.Size)
        .IntegralHeight = True

        ' List index will not highlight to first unless the second
        ' one is highlighted first. It might be to do with the resizing
        ' from the Integral height
        If .ListCount > 1 Then .ListIndex = 1
        .ListIndex = 0

    End With

End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub InitializeListBox()
    ' Remove any automatic resizing of the listbox
    myListBox.IntegralHeight = False
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Public Sub CheckListBoxFirstItem()
    If myListBox.ListIndex = 0 Then
        m_UpdateControl = False
        SelectTextBox
    End If
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Function ShowListbox(Optional ByVal show As Boolean = True)
    myListBox.Visible = show
End Function

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Function SetListboxPosition()
    
    With myListBox
        .Left = myTextBox.Left
        .Top = myTextBox.Top + (myTextBox.Height)
        .Width = myTextBox.Width
         Call ShowListbox(True)
    End With
    
End Function

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Function ResizeListbox(myListBox As MSForms.ListBox, fontSize As Double) As Double

    ' Set listbox font to the same size as the textbox
    myListBox.Font.Size = fontSize

    Dim ItemCount As Long
    ItemCount = IIf(myListBox.ListCount > m_maxRows, m_maxRows, myListBox.ListCount)

    Dim itemSize As Double
    
    ' the font size is itself plus a quarter for the space between rows
    itemSize = myListBox.Font.Size + (myListBox.Font.Size / 4)
    
    ' Font 10 has different sizing
    Dim extraspace As Double
    If fontSize = 10 Then
        extraspace = 4
    Else
        ' If 2 or less items then the listbox news to be taller
        If myListBox.ListCount <= 2 Then
            extraspace = 3
        Else
            extraspace = 2
        End If
    End If

    ResizeListbox = (itemSize * ItemCount) + extraspace
    
End Function


' TEXTBOX EVENTS

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub myTextBox_Change()

    If m_UpdateControl = False Then
        If Trim(myTextBox.value) = "" Then
            Call InitializeTextBox
        Else
            If m_textboxStartingState = True Then
                m_textboxStartingState = False
                Call RemoveStartingText
            End If
            Call FilterListBox
        End If
    End If
    
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub myTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    
    ' If the user presses keyup/down or enter
    ' while in the textbox
    If KeyCode = vbKeyDown Then
        List_MoveDown
    ElseIf KeyCode = vbKeyReturn Then
        ' swallow the enter keycode as it passes on to the ok button
        KeyCode = 0
        If IsNull(myListBox.value) = False And m_textboxStartingState = False Then
           
            SetTextboxValue myListBox.value
        End If
        Call ShowListbox(False)
    ElseIf KeyCode = vbKeyEscape Then
        ' swallow the esc keycode
        Call InitializeTextBox
        KeyCode = 0
    End If

End Sub


' TEXTBOX SUBS

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub SetTextboxValue(ByVal text As String)

    If m_UpdateControl = False Then
        
        With myListBox
            m_UpdateControl = True
            ' Set the listbox selected value to the textbox
            ' and hide the listbox

            myTextBox.value = text
            Call SelectTextBox
            
            m_UpdateControl = False
            
            If m_textboxStartingState = False And Trim(text) <> "" Then
                RaiseEvent ItemSelected
            End If
        End With
        
    End If
    
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Sub InitializeTextBox()
    ' Set the starting text and position
    m_textboxStartingState = True
    SetTextboxValue m_startText
    myTextBox.SelStart = 0
    myTextBox.ForeColor = rgbBlue
    
    Call ShowListbox(False)
End Sub

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
' Description:  Replace the default starting text with the letter the user has typed.
'               This will work if the user types at any position in the starting text.
Private Sub RemoveStartingText()
    
    m_UpdateControl = True

    With myTextBox
                
        .text = Mid(.value, .SelStart, 1)
        .ForeColor = rgbBlack
    End With
    
    m_UpdateControl = False
    
End Sub


' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
Private Function SelectTextBox()
    With myTextBox
        '.SelStart = 0
        .SetFocus
    End With
End Function


' GENERAL SUBS

' https://ExcelMacroMastery.com/
' Author: Paul Kelly
' YouTube video: https://youtu.be/gkLB-xu_JTU
' Filters the Listbox
Public Sub FilterListBox()

    ' In case a setting like MaxRows is used before the
    ' range is set
    If IsEmpty(m_listOfItems) Then Exit Sub

    m_UpdateControl = True

    Dim items As Variant
    items = FilterData
      
    Call UpdateListbox(items)
      
    m_UpdateControl = False
    
End Sub

Private Function FilterData() As Variant
   
    Dim textPattern As String
    textPattern = myTextBox.value
    
    ' Create an array to store the filtered items
    Dim filteredItems() As String
    

    ' Read through all the items in the full list
    Dim i As Long
    Dim count As Long: count = 0
    For i = LBound(m_listOfItems) To UBound(m_listOfItems)
        ' Using Instr instead of Like so we can set the case sensitivity
        If InStr(1, m_listOfItems(i, 1), textPattern, m_compareMethod) > 0 Then
            ReDim Preserve filteredItems(0 To count)
            filteredItems(count) = m_listOfItems(i, 1)
            count = count + 1
            If m_showAllMatches = False Then
                ' Only show the max number of rows
                If count >= m_maxRows Then Exit For
            End If
        End If
    Next
    
    ' use variant so we can check later if the array is empty
    Dim finalItems As Variant
    If count > 0 Then
        ReDim finalItems(0 To count - 1)
        For i = 0 To count - 1
            finalItems(i) = filteredItems(i)
        Next i
    End If
    
    FilterData = finalItems

End Function

This is the code from the form that pertains to the searchable box and list

Private Sub UserForm_Initialize()

    Set oEventHandler = New clsSearchableDropdown
    
    OKBtn.Enabled = False
    
    With oEventHandler
        Set .SearchListBox = Me.ProjectNoListBox
        Set .SearchTextBox = Me.ProjectNoTextBox

'   Settings
        .MaxRows = 7 ' set the number of items to be displayed
        .ShowAllMatches = True ' to show all the matches:  True - shows verical bars, False only displays Maxrows amount
        .CompareMethod = vbTextCompare ' use vbBinaryCompare for case sensitivity
    End With

End Sub

Private Sub UserForm_Terminate()
    
    Set oEventHandler = Nothing

End Sub

And From sheet3:

'set it so that all subs and functions require variables to be dimensioned
Option Explicit

'variable available across all modules?
Public strPPTFilepath As String
Public strProjectNumber As String
Public bCancelled As Boolean

and this last bit is my current work in progress where I call the form from. Just learning how to use forms so still figuring out how to pass information from form to sub and button click results not to mention cancelling / clicking x on the form. But that is a different question.

Private Sub LoadPPT_Click()

Dim frm As PPT_Picker_Form
Dim wbPPT As Workbook
Dim wsPPT As Worksheet

'Public strPPTFilepath As String
'Public strProjectNumber As String
    
    
    Set frm = UserForms.Add(PPT_Picker_Form.Name)
    frm.ListData = ThisWorkbook.Worksheets("Project Numbers").ListObjects("Project_Number_List").DataBodyRange
    
    frm.show
    
    Unload frm
    
    If bCancelled Then
        Exit Sub
    End If
    
    'Define PPT Table
    
    strPPTFilepath
    strProjectNumber

End Sub

Solution

  • Pls try to add two lines code which is marked with ***.

    Note: It's untested code. Pls backup your file before testing.

    Private Function FilterData() As Variant
       
        ' your code
    
        ' use variant so we can check later if the array is empty
        Dim finalItems As Variant
        If count > 0 Then
            ReDim finalItems(0 To count - 1)
            For i = 0 To count - 1
                finalItems(i) = filteredItems(i)
            Next i
        Else ' *** '
            finalItems = Array(textPattern) ' *** '
        End If
        
        FilterData = finalItems
    
    End Function