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`
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
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