Empty ListBox Values - excel

I have 3 Listboxes. In the properties I have selected the ListStyle as fmListStyleOption and the MultiSelect as fmMultiSelectMulti. Here is the current code:
Private Sub Userform_Initialize()
Me.lstProperties.RowSource = "FilterData"
Me.lstStmts.RowSource = "ListofProps"
Me.lstLoans.RowSource = "FilterLoans"
End Sub
I am using dynamic named ranges in hope that it will only show data in the Listbox for cells that actually have values. Unfortunately it shows a long list of blank lines with checkboxes anyways.
Does anyone know how to make sure that the Listbox only shows data with values i.e. if there are 2 cells in my named range with data then there are only two checkboxes in my listbox.
Visual

An easier why to do this would be to create an array from your range and assign the array to the Listbox.List property. This will allow you to use SpecialCells to filter the data.
Private Sub Userform_Initialize()
Me.lstProperties.List = getArrayFromRange(Range("FilterData").SpecialCells(xlCellTypeVisible))
Me.lstStmts.List = getArrayFromRange(Range("ListofProps").SpecialCells(xlCellTypeConstants))
Me.lstLoans.RowSource = getArrayFromRange(Range("FilterLoans").SpecialCells(xlCellTypeConstants))
End Sub
Function getArrayFromRange(rng As Range)
Dim arr
Dim a As Range
Dim count As Long, x As Long, y As Integer
ReDim arr(1 To rng.CountLarge, 1 To rng.Columns.count)
For Each a In rng.Areas
For x = 1 To a.Rows.count
count = count + 1
For y = 1 To rng.Columns.count
arr(count, y) = a.Cells(x, y).Value
Next
Next
Next
getArrayFromRange = arr
End Function

The issue was that my dynamic named range was not properly set up. The formula for the named range should have been:
=OFFSET('Property Data'!$A$5,2,,COUNTA('Property Data'!$A$5),14)
and not:
=OFFSET('Property Data'!$A$5,2,,COUNTA('Property Data'!$A$5:N$5),14).

Related

VBA Excel - add header to combobox when using AddItem

I have a list with values I like to add to combobox in my userform.
The values I want are in Column A and Column Z (so values from 2 columns). I manage to add the values with the AddItem function but struggling to add a header to the dropdown (a few posts said this is not possible).
As alternative I saw ListFillRange but I cannot figure out if this can be used for two columns which are not next to each other.
Appreciate the help.
a few posts said this is not possible
I usually do not reply to questions which do not show any efforts but this is an interesting one. I tend to agree with you that lot of people think that you cannot show headers in a ComboBox.
But it is possible to show headers in a Combobox. Here is a demonstration. You will of course have to take help of a helper sheet for this if you do not want to change the original sheet.
TEST CASE
For our demonstration, we will take 2 non-contigous range A1-A5 and D1-A5
LOGIC
You will copy the relevant data to a new sheet.
Convert the range to a table
Set columnheads to true of combobox
Set rowsource to the relevant table range from helper sheet.
CODE
Option Explicit
Dim ws As Worksheet
Private Sub UserForm_Initialize()
Dim wsInput As Worksheet
'~~> Input sheet. Change as applicable
Set wsInput = Sheet1
'~~> Add a new sheet. Hide it (Optional)
Set ws = ThisWorkbook.Sheets.Add
ws.Visible = xlSheetHidden
'~~> Copy the non-contigous range to the new sheet
wsInput.Range("A1:A5").Copy ws.Range("A1")
wsInput.Range("D1:D5").Copy ws.Range("B1")
Dim rng As Range
'~~> Get your range
Set rng = ws.Range("A1:B5")
'~~> Convert range to table
ws.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "MyTable"
'~~> Few combobox settings and we are done
With ComboBox1
.ColumnCount = 2
.ColumnHeads = True
.RowSource = "MyTable"
End With
End Sub
'~~> Delete the temp sheet we created
Private Sub UserForm_Terminate()
Application.DisplayAlerts = False
If Not ws Is Nothing Then ws.Delete
Application.DisplayAlerts = True
End Sub
OUTPUT
ALTERNATIVE
If you are not ok with the idea of helper sheet and are ok to sacrifice on the header part then you can populate a combobox using non contigous ranges. See Excel VBA Multicolumn Listbox add non contiguous range. You will of course have to edit the code to suit your needs. Since there are two columns only, your final array would look like Dim Ar(1 To LastRow, 1 To 2). This array will hold values from both columns.
I use the following code to add headers above listboxes and comboboxes. It seems a bit like a sledgehammer to crack a nut but sometimes the nut has to be cracked, and all the other methods and tools that I have seen also fall into the category of sledgehammer.
To make this as simple as possible for myself I have defined a class called clsListBoxHeaders and I include that code below. Then suppose you have a ListBox with 3 columns you need to
Tell the class which ListBox it is to work on
Tell it what the headers are
Tell it the column widths
To do this insert the following code in your user form
Dim lbHeaders As New clsListBoxHeaders
Set lbHeaders.ListBox = ListBox1
lbHeaders.Headers = "First Header;Second Header;Third Header"
lbHeaders.ColumnWidths = "40;50;60"
Note that the number of headers and the number of columnwidths must match exactly the number of columns in your listbox/combobox
To clear the header data use:
lbHeaders.Clear
If you want to format the labels (e.g. font) then you can access the labels as a variant array
lbHeaders.Labels
The class module code is as follows:
Option Explicit
' clsListBoxHeaders - Display header info above a ListBox or ComboBox
' To use this class in your project:
' Add a class module called clsListBoxHeaders and paste this code into it
' For each ListBox or ComboBox for which you wish to display column headers insert the following code in your userform:
' Dim lbHeaders As New clsListBoxHeaders
' Set lbHeaders.ListBox = ListBox1
' lbHeaders.Headers = "First Header;Second Header;Third Header"
' lbHeaders.ColumnWidths = "40;50;60"
'Note that the number of headers and the number of columnwidths must match exactly the number of columns in your listbox/combobox
' To clear the header data use:
' lbHeaders.Clear
Const LabelHeight As Integer = 10 ' Height of the header labels.
Const LabelOffset As Integer = 10 ' Offset to get the header to align correctly to first column in listbox
Private myListBox As Object
Private myParent As Object
Private lblHeaders() As MSForms.Label
Private sColumnWidths() As Single
Public Property Set ListBox(ListBox As Object)
Set myListBox = ListBox
Set myParent = ListBox.Parent
End Property
Public Property Let Headers(sHeaders As String)
Dim lLeft As Long, vHeaders As Variant
Dim iCol As Integer
With myListBox
vHeaders = Split(sHeaders, ";")
ReDim lblHeaders(.ColumnCount)
If UBound(sColumnWidths) = 0 Then
ReDim sColumnWidths(.ColumnCount)
For iCol = 1 To .ColumnCount
sColumnWidths(iCol) = .Width / .ColumnCount
Next
End If
lLeft = LabelOffset
For iCol = 1 To .ColumnCount
Set lblHeaders(iCol) = myParent.Controls.Add("Forms.Label.1")
With lblHeaders(iCol)
.Top = myListBox.Top - LabelHeight
.Left = lLeft + myListBox.Left
.Width = sColumnWidths(iCol)
.Height = LabelHeight
lLeft = lLeft + sColumnWidths(iCol)
.Visible = True
.Caption = vHeaders(iCol - 1)
.ZOrder fmZOrderFront
End With
Next
End With
End Property
Public Property Let ColumnWidths(ColumnWidths As String)
Dim vSplit As Variant
Dim lLeft As Long
Dim iCol As Integer
With myListBox
vSplit = Split(ColumnWidths, ";")
ReDim sColumnWidths(.ColumnCount)
For iCol = 1 To .ColumnCount
sColumnWidths(iCol) = vSplit(iCol - 1)
Next
lLeft = LabelOffset
If UBound(lblHeaders) > 0 Then
For iCol = 1 To .ColumnCount
With lblHeaders(iCol)
.Left = myListBox.Left + lLeft
.Width = sColumnWidths(iCol)
lLeft = lLeft + sColumnWidths(iCol) ' + LabelOffset
End With
Next
End If
End With
End Property
Public Property Get Labels() As Variant
Dim iCol As Integer
Dim vLabels As Variant
With myListBox
ReDim vLabels(.ColumnCount - 1)
For iCol = 1 To .ColumnCount
Set vLabels(iCol - 1) = lblHeaders(iCol)
Next
End With
Labels = vLabels
End Property
Public Sub Clear()
Dim i As Integer
For i = 1 To UBound(lblHeaders)
myParent.Controls.Remove lblHeaders(i).Name
Next
Class_Initialize
End Sub
Private Sub Class_Initialize()
ReDim lblHeaders(0)
ReDim sColumnWidths(0)
End Sub

How to add multiple rowsources to a MSForms listbox

been trying to set multiple ranges to a listbox, while filtering my sheet.
I tried this one, but it gives me a runtime error.
ListBox1.RowSource = Sheets("Sheet1").Range("A1:F1,A15:F15").Address
Is it possible to do something like this?
Edit: I could run this without error
ListBox1.RowSource = Sheets("Sheet1").Range("A1:F1", "A15:F15").Address
But it fills the list with Row 1 until 15, not only 1 and 15...
You cannot set a discontinuous range as a list box RowSource, but you can use a trick. I mean to create an array then fill it with the discontinuous range areas and load the list box using its List property.
Please, copy the next code in the UserForm_Initialize event and show the form:
Private Sub UserForm_Initialize()
Dim arr, rng As Range, sh As Worksheet, K As Long
Dim aRng As Range, C As Range
Set sh = ActiveSheet
Set rng = sh.Range("A1:F1,A3:F3")
ReDim arr(1 To rng.cells.count)
For Each aRng In rng.Areas
For Each C In aRng
K = K + 1: arr(K) = C.Value
Next
Next
Me.ListBox1.list = Application.Transpose(arr)
End Sub
The above solution works to load the array with one single column containing all cells in the discontinuous range.
In order to fill the array with as many columns are in the two ranges (6) and two rows, I will prepare another piece of code and post in some minutes.
Please, test the next code (copied inside Initialeze event):
Private Sub UserForm_Initialize()
Dim sh As Worksheet, aArr, fArr, combinedArr
Set sh = ActiveSheet
With Application
aArr = .Index(Range("A1:F1").Value, 1, 0)
fArr = .Index(Range("A3:F3").Value, 1, 0)
combinedArr = .Transpose(Array(aArr, fArr))
End With
With Me.ListBox1
.Clear
.ColumnCount = 6
.list = Application.Transpose(combinedArr)
End With
End Sub

VBA Insert Multiple Row data based on a listbox

For each line of the selected listbox I want to insert data in the next blank row for every data selected in the listbox, one new copied row, but the text that comes from the Textbox must be copied equal in all row, the below code copied the text only in one single row
Private sub button1_click()
Dim rw as integer
Dim ws as worksheets
Set worksheets(“Sheet1”)
Rw = ws.cells.find(what:=“*”, searchorder:=xlrows, searchdirection:=xlprevious, lookin:xlvalues).row + 1
Ws.cells(rw, 3).value = me.textbox1.value
Ws.cells(rw, 5).value = me.listbox1.value
End sub
Please help me 😊
I've created a new Workbook and a new UserForm with a ListBox, TextBox and CommandButton all with default names for this example.
Option Explicit
____________________________________________________________________________________
Private Sub CommandButton1_Click()
Dim NextBlankRow As Long
Dim TargetRange As Range
Dim ListBoxItem As Long
Dim SelectedItemsArray As Variant
Dim ArrayElementCounter As Long
ArrayElementCounter = 0
With Me.ListBox1
ReDim SelectedItemsArray(0 To .ListCount - 1)
For ListBoxItem = 0 To .ListCount - 1
If .Selected(ListBoxItem) Then
SelectedItemsArray(ArrayElementCounter) = .List(ListBoxItem)
ArrayElementCounter = ArrayElementCounter + 1
End If
Next ListBoxItem
End With
ReDim Preserve SelectedItemsArray(0 To ArrayElementCounter - 1)
With ThisWorkbook.Sheets("Sheet1")
NextBlankRow = .Cells(Rows.Count, 3).End(xlUp).Row + 1
Set TargetRange = .Range("C" & NextBlankRow & ":C" & NextBlankRow + UBound(SelectedItemsArray))
End With
Dim TargetCell As Range
ArrayElementCounter = 0
For Each TargetCell In TargetRange
TargetCell.Value = Me.TextBox1.Value
TargetCell.Offset(0, 2).Value = SelectedItemsArray(ArrayElementCounter)
ArrayElementCounter = ArrayElementCounter + 1
Next TargetCell
End Sub
____________________________________________________________________________________
Private Sub UserForm_Initialize()
Dim ListBoxItemArray As Variant
ListBoxItemArray = Array("Listbox Item 1", "Listbox Item 2", "Listbox Item 3")
Dim ItemToAdd As Long
For ItemToAdd = LBound(ListBoxItemArray) To UBound(ListBoxItemArray)
Me.ListBox1.AddItem (ListBoxItemArray(ItemToAdd))
Next ItemToAdd
End Sub
Here are screenshots of the inputs and outputs:
Data selected/entered to the UserForm
[
Output to the worksheet
Explanation:
The Private Sub UserForm_Initialize() event populates the ListBox for the purposes of my example - You can ignore this when it comes to your code but I felt it necessary to include how I populated the ListBox Items and what values with.
The Private Sub CommandButton1_Click() event code breaks down into 4 main sections (starting after the variables are declared):
With Me.LisBox1...End With
The very first thing we do here is set the Array size with the ReDim statement. The UpperBound or limit of the Array is set to the ListCount property minus 1 which returns 1 less the number of items in the ListBox. This ensures our Array is big enough to hold all of the list box items values, if they were all selected for example, but does so dynamically so you don't waste memory using an ambiguous number to future proof your code like 100 when you might only have 30 items. If Items are added or removed, the Array is always the right size.
The reason we minus 1 is I declared the Option Base to 0 for the Array which means it starts at (or the Lower Bound is) 0 not at 1. See the Option Base Statement for more info.
Next we loop through each ListBox item and evaluate if it is Selected or not. If it is, we use the List() property to assign the value of that item to the Array. See For...Next loops for more info on how they work and see Using Arrays for how they work.
Now we have SelectedItemsArray() full of the values for each selected item in the listbox.
ReDim Preserve SelectedItemsArray(0 To ArrayElementCounter - 1)
Much like earlier, we are setting the size of our array but this time including the Preserve part of the statement. This means we can resize the array but keep all the current values in it - If we didn't use Preserve the Array would be resized but lose all values. We again set the Upper Bound dynamically to resize the array to the number of selected items. (See the Using Arrays info again regarding array sizes etc.)
With ThisWorkbook.Sheets("Sheet1")...End With
In this With block we are finding the last used row of Column C and assigning that row + 1 (so it references the next blank row) to LastUsedRow. We are also defining our range we want to write our data to dynamically using the LastUsedRow variable and the Upper Bound of our Array. This is done so the right amount of cells are written to in the next section of code.
For Each TargetCell In TargetRange...Next TargetCell
Another loop but this time For Each...Next is used. Very similar to the For...Next loop but this one loops through elements of an array or collection - in this case we will be looping through each cell in our TargetRange.
For each cell in the range, remembering our range is set to Column C from the next blank row, The TextBox value is written to Column C and each ListBox item value from our array is written to Column E. As the loop iterates, the ArrayItemCounter increments which ensures the next array element is written to Column E with each loop.

How to collaborate excel listbox as data-grid using search button and shown in the textbox?

I have this code to show all my data in the sheets and load them into the listbox. How can I display and at the same time modify the data into my textbox when I clicking the column inside the listbox?
Private Sub Dloadbtn_Click()
'Load Diret Colo data into Direct Colo Listbox data grid.
Dim ws As Worksheet
Dim rng As Range
Dim hd As Range
Dim i As Long, j As Long, rw As Long
Dim Myarray() As String
'~~> Change your sheetname here
Set ws = Sheets("Colodbs")
'~~> Set you relevant range here
Set rng = ws.Range("A1:N10000")
With Me.Dlistbox
.Clear
.ColumnHeads = False
.ColumnCount = rng.Columns.count
ReDim Myarray(rng.Rows.count, rng.Columns.count)
rw = 0
For i = 1 To rng.Rows.count
For j = 0 To rng.Columns.count
Myarray(rw, j) = rng.Cells(i, j + 1)
Next
rw = rw + 1
Next
.List = Myarray
'~~> Set the widths of the column here. Ex: For 5 Columns
'~~> Change as Applicable
.ColumnWidths = "50;70;30;50;30;120;120;30;150;30;50;50;70;200"
.TopIndex = 0
End With
End Sub
Private Sub DSearchbtn_Click()
Dim i As Long
Dim rno As Integer
i = 0
Do While Colodbs.Cells(i + 1, 1).Value <> ""
If Colodbs.Cells(i + 1, 1).Value = FbSNtxt.Text Then
rno = Colodbs.Cells(i + 1, 1).Row
GoTo Condition
Else
rno = 0
End If
i = i + 1
Loop
Condition:
If rno <> 0 Then
Colodbs.Cells(rno, 2).Value = FbSNtxt.Text
Else
MsgBox ("No Such number is found")
End If
End Sub
Get clicked value in listbox and write to textbox
Your OP states: "How can I display and at the same time modify the data into my TextBox when I click the column inside the listbox?"
Actually your question is asking how to get the clicked column index in a listbox. Using the helper function getColIndex() you receive this essential information and get easily the clicked data value via the list property for the current listindex.
In the code example below I use the listbox MouseUp event to [1] get the clicked column index via the x argument showing the position in points within the listbox based on a cumulated column widths array created when loading data to the listbox and [2] to modify the textbox FbSNtxt with the clicked data value dListBox.List(Me.dListBox.ListIndex, ColIndex).
Amplifying remark to a tricky method
In order to get the correct column index via the listbox x position, it's necessary to display the ►entire listbox width and to wrap it into a scrolling Frame (cf. listbox and frame settings in the loading procedure Dloadbtn_Click())
Declaration head of UserForm
Option Explicit
Dim cumulWidths() As Double ' cumulated column widths
Dim ColIndex As Integer ' current column index
A. Solution via Listbox MouseUp event
IMO it's the best to use the ► MouseUp event to get the horizontal position (in points) within the listbox via ist x argument as you get the actual listindex only there (and not already in the MouseDown event). Furthermore it gets triggered in any case, whereas the click event only once within the same row.
Private Sub dListBox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Purpose: find search value in first column and write it to corresponding row in range (column B)
' Escape if no data
If dListBox.ListIndex < 0 Then Exit Sub
' [1] get the column index via helper function getColIndex
ColIndex = getColIndex(X)
' [2] get clicked data in column ColIndex and write it into textbox (i.e. modify latest value)
FbSNtxt.Text = Me.dListBox.List(Me.dListBox.ListIndex, ColIndex)
End Sub
►Helper function to get the current column index
Private Function getColIndex(ByVal X) As Integer
' Purpose: get column number analyzing your click position x
' Method: uses array cumulWidths (created by Dloadbtn_Click() calling initCumulWidths)
' Note: called by dListBox_MouseUp event
Dim i As Integer
For i = 0 To UBound(cumulWidths)
If X < cumulWidths(i) Then
getColIndex = i ' return value (listbox index is zero based)
Exit For
End If
Next i
End Function
B. Improved search procedures
Private Sub DSearchbtn_Click()
' Purpose: find search value in first column and write it to corresponding row in range (column B)
' Method: calls procedure dSearch
dSearch
End Sub
Private Sub dSearch()
' Purpose: find value in first column and write it to corresponding row in range (column B)
' Note: called a) by dListBox_DblClick or b) DSearchbtn_Click()
If Me.dListBox.ListCount = 0 Then Exit Sub
Dim i As Long, bFound As Boolean
'Dim Colodbs As Worksheet
'Set Colodbs = ThisWorkbook.Worksheets("Colodbs")
For i = 0 To Me.dListBox.ListCount - 1
If Me.dListBox.List(i, 0) = FbSNtxt.Text Then
' write to cell in found row (i+1, Column B)
Colodbs.Cells(i + 1, 2).Value = FbSNtxt.Text
' correct ListBox value in Column B
Me.dListBox.List(i, 1) = FbSNtxt.Text
bFound = True: Exit For
End If
Next i
If Not bFound Then
MsgBox FbSNtxt.Text & " ColIndex " & ColIndex & " not found.", vbInformation
End If
End Sub
C. Loading procedures
Improved CommandButton code to speed up the loading process by assigning the range in one statement and using subprocedure initCumulWidths.
Private Sub Dloadbtn_Click()
'Purpose: Load Diret Colo data into Direct Colo Listbox data grid.
Dim ws As Worksheet
Dim rng As Range
Dim hd As Range
Dim Myarray As Variant
'~~> Change your sheetname here
Set ws = ThisWorkbook.Worksheets("Colodbs")
'~~> Set yourrelevant range here
Set rng = ws.Range("A1:N10000")
With Me.dListBox
.Clear
.ColumnHeads = False
.ColumnCount = rng.Columns.Count
' -----------------------------------------------------
' Variant a): assign data to array and array to listbox
' -----------------------------------------------------
' Myarray = rng
' .List = Myarray
' -----------------------------------------------------
' Variant b): assign data in one step to listbox
' -----------------------------------------------------
.List = rng.Value2
'~~> Set the column widths of the column here.
.ColumnWidths = "50;70;30;50;30;120;120;30;150;30;50;50;70;200"
.TopIndex = 0
' =====================================================
' calls subprocedure to cumulate column widths
' -----------------------------------------------------
initCumulWidths
' set total width of listbox to max as it gets shown within a frame
.Width = cumulWidths(UBound(cumulWidths)) + 16
' set scroll width within frame
Frame1.ScrollWidth = .Width ' Frame1.InsideWidth * 4
End With
End Sub
►Subprocedure called by above CommandButton Click event to get cumulated widths
This subprocedure reads the columnwidths described in Points and assigns cumulated values to an array defined in the Userform module's declaration head.
Private Sub initCumulWidths()
' Purpose: calculate cumulated widths and assign values to common userform variable cumulWidths
' Method: splits ColumnWidths property of listbox and sums converted Point values
' Note: called by above Dloadbtn_Click() event
Dim a: a = Split(Me.dListBox.ColumnWidths, ";")
Dim previous As Double, i As Integer
ReDim cumulWidths(UBound(a))
For i = 0 To UBound(a)
cumulWidths(i) = val(Replace(a(i), " Pt", "")) + previous
previous = cumulWidths(i)
Next i
If UBound(a) > 0 Then
Debug.Print cumulWidths(UBound(a))
End If
End Sub
Additional note
As you didn't declare Colodbs as Worksheet in your search procedures, I assume you are using the CodeName property instead of an object.

Excel VBA - Search Userform Listbox with Multiple Columns via textbox

I'm trying to work out the code needed to filter or search a listbox included on a userform that contains multiple columns and multiple rows. On the userform, I have a textbox that allows user input that would ideally filter out the non-matching entries from the Listbox.
I've found a few solutions online, but nothing that I could get to work on a listbox with multiple columns in a userform. The way it's coded from the example is trying to transpose a single column of data, and I'm guessing I need to alter the code to use an array. I'm just not strong enough with VBA to know exactly how to change that piece.
I'm also receiving an error on the GoToRow() function, but I believe it's tied into the single vs multiple column listbox issue.
I've included a link to a basic mockup of my project below since I'm using a userform with a listbox and textbox that are named.
https://www.dropbox.com/s/diu05ncwbltepqp/BasicListboxExample.xlsm?dl=0
The listbox on my userform has five columns and is named ProjectList, and the textbox is named SearchTextBox.
Option Explicit
Const ProjectNameCol = "B"
Dim PS As Worksheet
Private loActive As Excel.ListObject
Private Sub UserForm_Activate() ' Main code on Userform Activation, calls support subs
Set PS = Sheets("ProjectSheet") 'stores value for Project Sheet Worksheet as PS
Set loActive = ActiveSheet.ListObjects(1)
'populates listbox with data from ProjectSheet Worksheet named table
ProjectList.RowSource = "AllData"
'# of Columns for listbox
ProjectList.ColumnCount = 5
'Column Width for listbox
ProjectList.ColumnWidths = "140; 100; 100; 100; 100"
Me.ProjectList.TextColumn = 1
Me.ProjectList.MatchEntry = fmMatchEntryComplete
ResetFilter
End Sub
Private Sub SearchTextBox_Change()
'Can't get anything to work here
ResetFilter
End Sub
Sub ResetFilter()
Dim rngTableCol As Excel.Range
Dim varTableCol As Variant
Dim RowCount As Long
Dim FilteredRows() As String
Dim i As Long
Dim ArrCount As Long
Dim FilterPattern As String
'the asterisks make it match anywhere within the string
If Not ValidLikePattern(Me.SearchTextBox.Text) Then
Exit Sub
End If
FilterPattern = "*" & Me.SearchTextBox.Text & "*"
Set rngTableCol = loActive.ListColumns(1).DataBodyRange
'note that Transpose won't work with > 65536 rows
varTableCol = Application.WorksheetFunction.Transpose(rngTableCol.value)
RowCount = UBound(varTableCol)
ReDim FilteredRows(1 To 2, 1 To RowCount)
For i = 1 To RowCount
'Like operator is case sensitive,
'so need to use LCase if not CaseSensitive
If (LCase(varTableCol(i)) Like LCase(FilterPattern)) Then
'add to array if ListBox item matches filter
ArrCount = ArrCount + 1
'there's a hidden ListBox column that stores the record num
FilteredRows(1, ArrCount) = i
FilteredRows(2, ArrCount) = varTableCol(i)
End If
Next i
If ArrCount > 0 Then
'delete empty array items
'a ListBox cannot contain more than 65536 items
ReDim Preserve FilteredRows(1 To 2, 1 To Application.WorksheetFunction.Min(ArrCount, 65536))
Else
're-initialize the array
Erase FilteredRows
End If
If ArrCount > 1 Then
Me.ProjectList.List = Application.WorksheetFunction.Transpose(FilteredRows)
Else
Me.ProjectList.Clear
'have to add separately if just one match
'or we get two rows, not two columns, in ListBox
If ArrCount = 1 Then
Me.ProjectList.AddItem FilteredRows(1, 1)
Me.ProjectList.List(0, 1) = FilteredRows(2, 1)
End If
End If
End Sub
Private Sub ProjectList_Change()
GoToRow
End Sub
Sub GoToRow()
If Me.ProjectList.ListCount > 0 Then
Application.Goto loActive.ListRows(Me.ProjectList.value).Range.Cells(1),True
End If
End Sub
Over in my modules I have:
Function ValidLikePattern(LikePattern As String) As Boolean
Dim temp As Boolean
On Error Resume Next
temp = ("A" Like "*" & LikePattern & "*")
If Err.Number = 0 Then
ValidLikePattern = True
End If
On Error GoTo 0
End Function

Resources