Filtering a 2D array in a listbox from a textbox

561414

New Member
Joined
Aug 25, 2017
Messages
13
Hi everyone. I have a userform with a textbox and a listbox.
The listbox is populated with data from a 2-column ListObject table whenever the form initializes and, as I type in the textbox, it gets filtered using the full string.
That works, but since I'm filtering construction materials, I have many variations of the same thing, so I would like it to filter using spaces within the string as if they were wildcards.
Example:
If I type "brick", it returns:
  • golden brick || piece
  • concrete brick 2x2x4 || piece
  • painted brick || piece
  • brick for facades || m2
If I type brick and then a space, "brick_", it will return:
  • concrete brick 2x2x4 || piece
  • brick for facades || m2
Because those records have a space after the word "brick", but I want to be able to type, say "bric gol" and return:
  • golden brick || piece
Now, this is my VBA code for the form:
VBA Code:
Private Sub UserForm_Initialize()
Dim myTable As ListObject
Dim myArray As Variant
    ListBox1.ColumnCount = 2
    ListBox1.ColumnWidths = "350,82"
    Set myTable = Worksheets("h_Insumos").ListObjects("tbInsumos")
    myArray = myTable.DataBodyRange
    ListBox1.List = myArray
End Sub

Private Sub TextBox1_Change()
Dim myTable As ListObject
Dim myArray As Variant
Dim results As Variant

    ListBox1.ColumnCount = 2
    ListBox1.ColumnWidths = "350,82"
    Set myTable = Worksheets("h_Insumos").ListObjects("tbInsumos")
    myArray = myTable.DataBodyRange    
    results = filter2dArray(myArray, "*" & TextBox1.Text & "*")    
    If IsEmpty(results) Then
        ListBox1.Clear
    Else
        ListBox1.List = results
    End If

That filter2dArray function might be the problem, but I didn't code it, I grabbed it from here

And it's this:
VBA Code:
Option Compare Text
Public Function filter2dArray(sourceArr As Variant, matchStr As String) As Variant
Dim matchArrIndex As Variant, splitArr As Variant
Dim i As Integer, outerindex As Integer, innerIndex As Integer
Dim tempArrayIndex As Integer, CurrIndex As Integer, stringLength As Integer, matchType As Integer
Dim increaseIndex As Boolean
Dim actualStr As String

splitArr = Split(matchStr, "*")

On Error GoTo errorHandler
    If UBound(splitArr) = 0 Then
        matchType = 0 'Exact Match
        actualStr = matchStr
    ElseIf UBound(splitArr) = 1 And splitArr(1) = "" Then
        matchType = 1 'Starts With
        actualStr = splitArr(0)
    ElseIf UBound(splitArr) = 1 And splitArr(0) = "" Then
        matchType = 2 'ends With
        actualStr = splitArr(1)
    ElseIf UBound(splitArr) = 2 And splitArr(0) = "" And splitArr(2) = "" Then
        matchType = 3 'contains
        actualStr = splitArr(1)
    Else
        MsgBox "Incorrect match provided"
        Exit Function
    End If

    'start index
    i = LBound(sourceArr, 1)
    'resize array for matched values
    ReDim matchArrIndex(LBound(sourceArr, 1) To UBound(sourceArr, 1)) As Variant
    
    'outer loop
    For outerindex = LBound(sourceArr, 1) To UBound(sourceArr, 1)
        'inner loop
        For innerIndex = LBound(sourceArr, 2) To UBound(sourceArr, 2)
            'if string matches with array elements
            If (matchType = 0 And sourceArr(outerindex, innerIndex) = actualStr) Or _
            (matchType = 1 And Left(sourceArr(outerindex, innerIndex), Len(actualStr)) = actualStr) Or _
            (matchType = 2 And Right(sourceArr(outerindex, innerIndex), Len(actualStr)) = actualStr) Or _
            (matchType = 3 And InStr(sourceArr(outerindex, innerIndex), actualStr) <> 0) Then
                increaseIndex = True
                matchArrIndex(i) = outerindex
            End If
        Next
        
        If increaseIndex Then
            tempArrayIndex = tempArrayIndex + 1
            increaseIndex = False
            i = i + 1
        End If
    Next
        
    'if no matches found, exit the function
    If tempArrayIndex = 0 Then
        Exit Function
    End If

    If LBound(sourceArr, 1) = 0 Then
        tempArrayIndex = tempArrayIndex - 1
    End If

    'resize temp array
    ReDim tempArray(LBound(sourceArr, 1) To tempArrayIndex, LBound(sourceArr, 2) To UBound(sourceArr, 2)) As Variant
    CurrIndex = LBound(sourceArr, 1)

    Dim j As Integer
    j = LBound(matchArrIndex)
    'store values in temp array
    For i = CurrIndex To UBound(tempArray)
        For innerIndex = LBound(sourceArr, 2) To UBound(sourceArr, 2)
            tempArray(i, innerIndex) = sourceArr(matchArrIndex(j), innerIndex)
        Next
    j = j + 1
    Next
        
    filter2dArray = tempArray
    Exit Function
errorHandler:
    MsgBox "Error :" & Err.Description
End Function

I have no idea how this third party code works. I already tried modifying the splitArr = Split(matchStr, "*") to splitArr = Split(matchStr, "*", 2) and hoping for it to split the string into 2 parts and evaluate them but it cleared my listbox instead. I'm severely confused. Can anybody tell me how to accomplish this?

Thank you all in advance. If you want a file to test, I will post it no problem.
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Hi, @561414
but I want to be able to type, say "bric gol" and return:

  • golden brick || piece
What you need is a searching method that ignores the keywords order.

VBA Code:
Dim myTable As ListObject
Dim myArray As Variant

Private Sub CommandButtonChoose_Click()

    Worksheets("test from here").Range("a1") = ListBox1.Value
    Me.Hide
    
End Sub

Private Sub UserForm_Initialize()


    ListBox1.ColumnCount = 2
    ListBox1.ColumnWidths = "350,82"

    Set myTable = Worksheets("h_Insumos").ListObjects("tbInsumos")

    myArray = myTable.DataBodyRange

    ListBox1.List = myArray

End Sub

Private Sub TextBox1_Change()

Dim results As Variant
Dim x, z
Dim i As Long, j As Long
Dim tx As String
Dim flag As Boolean

tx = TextBox1.Text
ListBox1.Clear


With ListBox1
    If tx = "" Then
        ListBox1.List = myArray
    Else
    
        For i = 1 To UBound(myArray, 1)
        
            flag = True
            For Each z In Split(tx, " ")
                If InStr(1, myArray(i, 1), z, vbTextCompare) = 0 Then flag = False: Exit For
            Next
            
            If flag Then
                .AddItem
                .List(j, 0) = myArray(i, 1)
                .List(j, 1) = myArray(i, 2)
                j = j + 1
            End If
       
        Next
    
    End If

End With
  
End Sub


buscar listbox.jpg


The file:
561414 - test 1
 
Upvote 0
Dear @Akuini, Thank you so much for your time, patience and knowledge. It works great. Exactly what I need to counter the no-scroll wheel problem of these forms.
 
Upvote 0
You're welcome, glad to help & thanks for the feedback. :)
 
Upvote 0
You're welcome, glad to help & thanks for the feedback. :)
You rock, my friend. By the way, I know I'm asking for too much. But I'm having performance issues now that I've started using it with my actual list of 24k records (so far). Apparently I'm gonna be using this tool a lot, and this is the current behavior:
As soon as I type anything on the empty textbox, it takes some 8 seconds and it sometimes loses focus on the excel window. I made sure to close everything else.
What are some things I could do to speed it up? It was instant when it didn't split the words.

Again, thank you very much.
 
Upvote 0
it takes some 8 seconds
Question:
The list in the first column:
1. Are they unique?
2. Are they all capital letters?
3. Can you post about 10 rows of the original data, so I can understand it better.
 
Upvote 0
Question:
The list in the first column:
1. Are they unique?
2. Are they all capital letters?
3. Can you post about 10 rows of the original data, so I can understand it better.
1. Unique, I even have a tool to remove dupes
2. Not always, but if that improves performance then I can make it mandatory
3. Sure thing. I think this is a good sample:
MARMORINOCUBETA
MATERIALES MENORES%
MUROPLAST (CUBETA DE 19 LTS)CUBETA
OXIGENO CILINDRO DE 6 M3CIL
PALLADIO
A344
CUBETA
PAQUETE ECO HABITAT 1 BCO 0173520 AMERICAN S.JGO
PASTIN (CUBETA DE 19 LTS)CUBETA
PIEDRA BOLA DE RIOBTE
PIEDRA BRAZA, CAMION DE 7 M3CAMION
PIEDRA DE RIOBTE
PIEDRA LAJABTE
PIEDRA PARA PULIDIDOR DE PISOSJGO
PIETRA PLAST ROMANO (CUBETA DE 19 LTS)CUBETA
PIETRAPLAST VENECIANOM2

Edit: I should have mentioned that the 8 seconds are only when it's going through the entire record set, when I type the second character, it's near instant. I believe it is because the filtered list is much smaller, or could it be because it stores it in memory? :unsure:
 
Last edited:
Upvote 0
Ok, see if this arrangement suit you:
1. The first column list must be all capital letter.
2. You can type lower or capital letter in the textbox, the result would be the same.
3. If the textbox is blank then the listbox is blank
4. I set limit of number of items shown in listbox to 1000. So just continue typing to narrow it down until you find what you need.
You can change the limit in this line (I think 200 should be enough):
If j = 1000 Then Exit For 'limit number of items shown in listbox

VBA Code:
Option Explicit
Dim myTable As ListObject
Dim myArray As Variant
Dim oldValue As String

Private Sub CommandButtonChoose_Click()

    Worksheets("test from here").Range("a1") = ListBox1.Value
    Me.Hide
    
End Sub

Private Sub UserForm_Initialize()


    ListBox1.ColumnCount = 2
    ListBox1.ColumnWidths = "350,82"

    Set myTable = Worksheets("h_Insumos").ListObjects("tbInsumos")

    myArray = myTable.DataBodyRange
    
    'ListBox1.List = myArray

End Sub

Private Sub TextBox1_Change()

Dim results As Variant
Dim x, z
Dim i As Long, j As Long
Dim tx As String
Dim flag As Boolean

tx = Trim(UCase(TextBox1.Text))

If tx <> oldValue Then
    With ListBox1
        .Clear
        If tx <> "" Then
            .Clear
            
            For i = 1 To UBound(myArray, 1)
                
                flag = True
                For Each z In Split(tx, " ")
                    If InStr(1, myArray(i, 1), z, vbBinaryCompare) = 0 Then flag = False: Exit For
                Next
      
                If flag Then
                    .AddItem
                    .List(j, 0) = myArray(i, 1)
                    .List(j, 1) = myArray(i, 2)
                    j = j + 1
                    If j = 1000 Then Exit For 'limit number of items shown in listbox
                End If
    
           
            Next
        
            
        End If
    
    End With
End If
oldValue = tx

End Sub
 
Upvote 0
Solution
Yeah, that's great! the results appear inmediately with this solution. Thank you so much, @Akuini. This is priceless, right on the money.
 
Upvote 0

Forum statistics

Threads
1,213,549
Messages
6,114,264
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top