Populate Listbox1 based on TextBox1 value

[jagrenet]

I have UserForm1 with ListBox1 and TextBox1. What I am trying to accomplish is to allow the User to search "Sheet2" to find all records that match their input and populate the ListBox1. I have seen various methods to do this and have applied a couple of these methods however, the process falls flat at the same exact point, each time the code is run. With the 2 examples I have below, everything seems to run just fine until I get to the point of typing in the Textbox. I am using the TextBox1_Change() method and am expecting the Listbox to begin showing records immediately, with even the first character being typed. Issue: When I type, the ListBox remains blank. I have implemented 2 different versions of code. Same results, at the same spot, each time. (please see code below)

VERSION 1 - Returns nothing to the ListBox.

Private Sub TextBox1_Change()

On Error Resume Next

Workbooks("SalesForce Cases_v1.4_C1_Logo_Import_Button.xlsm").Activate
Worksheets("Sheet2").Select

Dim c As Integer
Dim column_headers
column_headers = "E"
criterion = column_headers

Sheet2.Cells(2, 4) = criterion

ListBox1.RowSource = Sheet2.Cells(2, 4)



Dim r, last_row, x As Integer
Dim i As Long
last_row = Sheet2.Range("E10000" & Rows.Count).End(xlUp).Row
For r = 2 To last_row
For x = 1 To Len(Sheet2.Cells(i, 2))


a = Len(UserForm1.TextBox1.TextLength)
If UCase(Left(Sheet2.Cells(r, criterion).Value, a)) = UCase(UserForm1.TextBox1.Text) Then

With UserForm1.ListBox1

.AddItem Sheet2.Cells(r, "A").Value
.List(.ListCount - 1, 1) = Sheet2.Cells(r, "B").Value
.List(.ListCount - 1, 2) = Sheet2.Cells(r, "C").Value
.List(.ListCount - 1, 3) = Sheet2.Cells(r, "D").Value
.List(.ListCount - 1, 4) = Sheet2.Cells(r, "E").Value
.List(.ListCount - 1, 5) = Sheet2.Cells(r, "F").Value
.List(.ListCount - 1, 6) = Sheet2.Cells(r, "G").Value
.List(.ListCount - 1, 7) = Sheet2.Cells(r, "H").Value
.List(.ListCount - 1, 8) = Sheet2.Cells(r, "I").Value
.List(.ListCount - 1, 9) = Sheet2.Cells(r, "J").Value
.List(.ListCount - 1, 10) = Sheet2.Cells(r, "K").Value
.List(.ListCount - 1, 11) = Sheet2.Cells(r, "L").Value
.List(.ListCount - 1, 12) = Sheet2.Cells(r, "M").Value
.List(.ListCount - 1, 13) = Sheet2.Cells(r, "N").Value
.List(.ListCount - 1, 14) = Sheet2.Cells(r, "O").Value
.List(.ListCount - 1, 15) = Sheet2.Cells(r, "P").Value
.List(.ListCount - 1, 16) = Sheet2.Cells(r, "Q").Value
.List(.ListCount - 1, 17) = Sheet2.Cells(r, "R").Value
.List(.ListCount - 1, 18) = Sheet2.Cells(r, "S").Value
.List(.ListCount - 1, 19) = Sheet2.Cells(r, "T").Value
.List(.ListCount - 1, 20) = Sheet2.Cells(r, "U").Value
.List(.ListCount - 1, 21) = Sheet2.Cells(r, "V").Value
.List(.ListCount - 1, 22) = Sheet2.Cells(r, "W").Value
.List(.ListCount - 1, 23) = Sheet2.Cells(r, "X").Value
.List(.ListCount - 1, 24) = Sheet2.Cells(r, "Y").Value
.List(.ListCount - 1, 25) = Sheet2.Cells(r, "Z").Value
.List(.ListCount - 1, 26) = Sheet2.Cells(r, "AA").Value
.List(.ListCount - 1, 27) = Sheet2.Cells(r, "AB").Value
.List(.ListCount - 1, 28) = Sheet2.Cells(r, "AC").Value


End With
End If
Next x
Next r


End Sub

===================================================================================
VERSION 2 - Same results. Returns nothing to the ListBox.

Private Sub TextBox1_Change()

Dim i As Long
For i = 2 To Sheet2.Range("E10000").End(xlUp).Row
For x = 1 To Len(Sheet2.Cells(i, 1))


a = Me.TextBox1.TextLength
If UCase(Mid(Sheet2.Cells(i, 1), x, a)) = Me.TextBox1 And Me.TextBox1 <> "" Then

Me.ListBox1.AddItem Sheet2.Cells(i, 1)
Me.ListBox1.List(ListBox1.ListCount - 1, 1) = "0" & Sheet2.Cells(i, 2)

End If
Next x
Next i

End Sub
===================================================================================

There could potentially be some leftover code from previous attempts that simply did not get cleaned up. Please ignore.

 

[dmt32]

I have the files in DropBox. I will need your email to give you access.

sorry, against rules - you need to make link public & this gives others here opportunity to step in and offer assistance.

Dave

 

[jagrenet]

sorry, against rules - you need to make link public & this gives others here opportunity to step in and offer assistance.

Dave

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[dmt32]

Hi,
can you just place a complete working copy of your workbook with dummy data in the dropbox?

 

[jagrenet]

Hi,
can you just place a complete working copy of your workbook with dummy data in the dropbox?

Hope this helps.
Not sure if this is all you need.

Dropbox - File Deleted - Simplify your life

www.dropbox.com

 

[dmt32]

looks no different - all I am seeing are separate files - I just need a copy of the workbook with dummy data.

To understand, you can see a good example of placing workbook in file sharing site in this post here:I can't get the VBA codes for data search to work.

Dave

 

[jagrenet]

looks no different - all I am seeing are separate files - I just need a copy of the workbook with dummy data.

To understand, you can see a good example of placing workbook in file sharing site in this post here:I can't get the VBA codes for data search to work.

Dave

Thanks Dave,

Please check the link again and let me know if this is what you need.

Jeff

 

[dmt32]

Hi,

Looks like Problem is twofold

1st, there is no data in your last column so code started and ended at row 1

2nd I did not fully appreciate size of your data for which suggested solution is a tad clumsy (hopeless) & was taking far too long to populate the searches.

Try following updated code which uses Variant arrays to filter the data – By using arrays you are not accessing the ranges or trying to populate the listbox at each step & should prove to be much quicker (hopefully)

Place Both Codes in your userforms code page

Private Sub TextBox1_Change()
  
    Dim ws          As Worksheet
    Dim rng         As Range
    Dim r           As Long, c As Long, Lastrow As Long, r1 As Long
    Dim Search      As String
    Dim FilterArr   As Variant
  
    Search = Me.TextBox1.Value
  
    Set ws = ThisWorkbook.Worksheets("Sheet2")
  
    Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
  
    'size worksheet data range
    Set rng = ws.Cells(2, 1).Resize(Lastrow, 28)
  
    arr = rng.Value2
  
    ReDim FilterArr(1 To rng.Rows.Count, 1 To rng.Columns.Count)
  
    With Me.ListBox1
        'disconnect rowsource
        .RowSource = ""
        .ColumnHeads = False
      
        'size listbox
        .ColumnCount = rng.Columns.Count
      
        .Clear
      
        If Len(Search) > 0 Then
          
            For r = 1 To UBound(arr, 1)
                If UCase(arr(r, 5)) Like UCase(Search) & "*" Then
                    r1 = r1 + 1
                    For c = 1 To UBound(arr, 2)
                        FilterArr(r1, c) = arr(r, c)
                    Next c
                End If
            Next r
          
            .List = ResizeArray(FilterArr, r1)
          
        Else
          
            'display full list
            .List = arr
          
            'or use rowsource
            're-connect rowsource to display all data with column heads
            '.RowSource = rng.Address
            '.ColumnHeads = True
          
        End If
      
    End With
  
End Sub

Function ResizeArray(ByVal arr As Variant, ByVal RowsCount As Long) As Variant
    Dim r       As Long, c As Long
    Dim Arr2()  As Variant
     'size array to match filtered data
        ReDim Arr2(1 To RowsCount, 1 To UBound(arr, 2))
        For r = 1 To RowsCount
            For c = 1 To UBound(arr, 2)
        'pass matching elements of arr to arr2
            Arr2(r, c) = arr(r, c)
            Next c
        Next
    ResizeArray = Arr2
End Function

Updated code addresses the no data in last column as last row is now size based on data in Column A being complete.

A slight downside with the Array approach is need second code to resize the Filter Array to remove unused rows.

Maybe another here can offer a cleaner solution

Dave



Hope Helpful



Dave

 

[jagrenet]

Hi,

Looks like Problem is twofold

1st, there is no data in your last column so code started and ended at row 1

2nd I did not fully appreciate size of your data for which suggested solution is a tad clumsy (hopeless) & was taking far too long to populate the searches.

Try following updated code which uses Variant arrays to filter the data – By using arrays you are not accessing the ranges or trying to populate the listbox at each step & should prove to be much quicker (hopefully)

Place Both Codes in your userforms code page

Private Sub TextBox1_Change()
 
    Dim ws          As Worksheet
    Dim rng         As Range
    Dim r           As Long, c As Long, Lastrow As Long, r1 As Long
    Dim Search      As String
    Dim FilterArr   As Variant
 
    Search = Me.TextBox1.Value
 
    Set ws = ThisWorkbook.Worksheets("Sheet2")
 
    Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
 
    'size worksheet data range
    Set rng = ws.Cells(2, 1).Resize(Lastrow, 28)
 
    arr = rng.Value2
 
    ReDim FilterArr(1 To rng.Rows.Count, 1 To rng.Columns.Count)
 
    With Me.ListBox1
        'disconnect rowsource
        .RowSource = ""
        .ColumnHeads = False
     
        'size listbox
        .ColumnCount = rng.Columns.Count
     
        .Clear
     
        If Len(Search) > 0 Then
         
            For r = 1 To UBound(arr, 1)
                If UCase(arr(r, 5)) Like UCase(Search) & "*" Then
                    r1 = r1 + 1
                    For c = 1 To UBound(arr, 2)
                        FilterArr(r1, c) = arr(r, c)
                    Next c
                End If
            Next r
         
            .List = ResizeArray(FilterArr, r1)
         
        Else
         
            'display full list
            .List = arr
         
            'or use rowsource
            're-connect rowsource to display all data with column heads
            '.RowSource = rng.Address
            '.ColumnHeads = True
         
        End If
     
    End With
 
End Sub

Function ResizeArray(ByVal arr As Variant, ByVal RowsCount As Long) As Variant
    Dim r       As Long, c As Long
    Dim Arr2()  As Variant
     'size array to match filtered data
        ReDim Arr2(1 To RowsCount, 1 To UBound(arr, 2))
        For r = 1 To RowsCount
            For c = 1 To UBound(arr, 2)
        'pass matching elements of arr to arr2
            Arr2(r, c) = arr(r, c)
            Next c
        Next
    ResizeArray = Arr2
End Function

Updated code addresses the no data in last column as last row is now size based on data in Column A being complete.

A slight downside with the Array approach is need second code to resize the Filter Array to remove unused rows.

Maybe another here can offer a cleaner solution

Dave



Hope Helpful



Dave

Hey Dave,

Bravo !! - That is so much better and is working as expected - Thank you !!
However, after running through it many times, I found a problem that I was hoping to correct, if it is possible.
A couple of times, I mis-spelled the Customer's Name and the code threw an error. Is there a way to code a message box prompting the user when this happens (to check their spelling)?

Another thing I would like to see -
When the ListBox has all of the rows and the user is finished typing, I would like the code to "select" all items (ListBox1.List.Selected = True) - or something to that effect. Then, all they have to do is click the "Transfer" button, (which I will finish coding later) .... and they are done.

So far though it works fantastic. I had previously considered using an Array but, I am not well versed in Arrays and have only used them once or twice.
Thanks again !!

Jeff

 

[dmt32]

Hey Dave,

Bravo !! - That is so much better and is working as expected - Thank you !!
However, after running through it many times, I found a problem that I was hoping to correct, if it is possible.
A couple of times, I mis-spelled the Customer's Name and the code threw an error. Is there a way to code a message box prompting the user when this happens (to check their spelling)?

sorry, oversight on my part, try this update to codes

Private Sub TextBox1_Change()
    
    Dim ws          As Worksheet
    Dim rng         As Range
    Dim r           As Long, c As Long, Lastrow As Long, r1 As Long
    Dim Search      As String
    Dim FilterArr()   As Variant
    
    Search = Me.TextBox1.Value
    
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    
    Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    'size worksheet data range
    Set rng = ws.Cells(2, 1).Resize(Lastrow, 28)
    
    arr = rng.Value2
    
    ReDim FilterArr(1 To rng.Rows.Count, 1 To rng.Columns.Count)
    
    With Me.ListBox1
        'disconnect rowsource
        .RowSource = ""
        .ColumnHeads = False
        
        'size listbox
        .ColumnCount = rng.Columns.Count
        
        .Clear
        
        If Len(Search) > 0 Then
            
            For r = 1 To UBound(arr, 1)
                If UCase(arr(r, 5)) Like UCase(Search) & "*" Then
                    r1 = r1 + 1
                    For c = 1 To UBound(arr, 2)
                        FilterArr(r1, c) = arr(r, c)
                    Next c
                End If
            Next r
            
            .List = ResizeArray(FilterArr, r1)
            
        Else
            
            'display full list
            .List = arr
            
            'or use rowsource
            're-connect rowsource to display all data with column heads
            '.RowSource = ws.Name & "!" & rng.Address
            '.ColumnHeads = True
            
        End If
        
    End With
    
End Sub
Function ResizeArray(ByVal arr As Variant, ByVal RowsCount As Long) As Variant
    Dim r       As Long, c As Long
    Dim Arr2()  As Variant
     
     If RowsCount > 0 Then
     'size array to match filtered data
        ReDim Arr2(1 To RowsCount, 1 To UBound(arr, 2))
        For r = 1 To RowsCount
            For c = 1 To UBound(arr, 2)
        'pass matching elements of arr to arr2
            Arr2(r, c) = arr(r, c)
            Next c
        Next
     End If
    ResizeArray = IIf(RowsCount > 0, Arr2, Array("No Match Found"))
End Function

You see a message display in Listbox if no matches are found

Another thing I would like to see -
When the ListBox has all of the rows and the user is finished typing, I would like the code to "select" all items (ListBox1.List.Selected = True) - or something to that effect. Then, all they have to do is click the "Transfer" button, (which I will finish coding later) .... and they are done.

whilst could include this feature when building the array suggest that you just include the code at start of your transfer button

Private Sub TransferButton_Click()
    Dim i As Long
    For i = 0 To Me.ListBox1.ListCount - 1
        Me.ListBox1.Selected(i) = True
    Next i
    
    'rest of code
End Sub

Dave

 

[jagrenet]

sorry, oversight on my part, try this update to codes

Private Sub TextBox1_Change()
   
    Dim ws          As Worksheet
    Dim rng         As Range
    Dim r           As Long, c As Long, Lastrow As Long, r1 As Long
    Dim Search      As String
    Dim FilterArr()   As Variant
   
    Search = Me.TextBox1.Value
   
    Set ws = ThisWorkbook.Worksheets("Sheet2")
   
    Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    'size worksheet data range
    Set rng = ws.Cells(2, 1).Resize(Lastrow, 28)
   
    arr = rng.Value2
   
    ReDim FilterArr(1 To rng.Rows.Count, 1 To rng.Columns.Count)
   
    With Me.ListBox1
        'disconnect rowsource
        .RowSource = ""
        .ColumnHeads = False
       
        'size listbox
        .ColumnCount = rng.Columns.Count
       
        .Clear
       
        If Len(Search) > 0 Then
           
            For r = 1 To UBound(arr, 1)
                If UCase(arr(r, 5)) Like UCase(Search) & "*" Then
                    r1 = r1 + 1
                    For c = 1 To UBound(arr, 2)
                        FilterArr(r1, c) = arr(r, c)
                    Next c
                End If
            Next r
           
            .List = ResizeArray(FilterArr, r1)
           
        Else
           
            'display full list
            .List = arr
           
            'or use rowsource
            're-connect rowsource to display all data with column heads
            '.RowSource = ws.Name & "!" & rng.Address
            '.ColumnHeads = True
           
        End If
       
    End With
   
End Sub
Function ResizeArray(ByVal arr As Variant, ByVal RowsCount As Long) As Variant
    Dim r       As Long, c As Long
    Dim Arr2()  As Variant
    
     If RowsCount > 0 Then
     'size array to match filtered data
        ReDim Arr2(1 To RowsCount, 1 To UBound(arr, 2))
        For r = 1 To RowsCount
            For c = 1 To UBound(arr, 2)
        'pass matching elements of arr to arr2
            Arr2(r, c) = arr(r, c)
            Next c
        Next
     End If
    ResizeArray = IIf(RowsCount > 0, Arr2, Array("No Match Found"))
End Function

You see a message display in Listbox if no matches are found



whilst could include this feature when building the array suggest that you just include the code at start of your transfer button

Private Sub TransferButton_Click()
    Dim i As Long
    For i = 0 To Me.ListBox1.ListCount - 1
        Me.ListBox1.Selected(i) = True
    Next i
   
    'rest of code
End Sub

Dave

Looking really good Dave. I didn't even think about putting the error message into the ListBox - that's great !! I have run through the Procedures in order to test and I am noticing, .... when I intentionally misspell a name, multiple times (some people do that) .... the ReSize feature eventually shrinks the ListBox down so far that it is unreadable. Is there any way to diminish or correct that effect ??
Other than that, everything else works flawlessly.