How to reduce needed time to nearly zero
The trick to speed up populating about 8k rows * 7 columns of data from the sheet in the listbox is not to use AddItemeach time, but to set a whole array to the listbox:
Me.ListBox2.List = a
after checking if the search string s is empty by
If Len(s) = 0 Then
Code
Option Explicit
Private Sub TextBox1_Change()
Dim t As Double ' Timer
Dim oSht As Worksheet
'=====
Dim liste As Long
Dim i As Long
Dim j As Long
Dim n As Long
Dim s As String
Dim a ' data field array, variant! (shorter for arrList)
t = Timer
Set oSht = ThisWorkbook.Worksheets("Test") ' set worksheet fully qualified reference to memory
ListBox2.ColumnCount = 7 ' dimension listbox columns
s = Me.TextBox1.Value ' get search string
Me.ListBox2.Clear ' clear listbox
n = oSht.Range("F" & oSht.Rows.Count).End(xlUp).Row ' get last row number
If n > 1 Then ' at least 1 line needed
' write range to one based 2dim data field array
a = oSht.Range("F2:L" & n).Value2
If Len(s) = 0 Then ' check if EMPTY string
' ====================================
' Trick: add complete items all in one
' ====================================
Me.ListBox2.List = a ' avoids loop
Debug.Print "Time needed: " & Format(Timer - t, "0.00 ") & " seconds." & vbNewLine & _
"Empty string """": all " & UBound(a) & " items refreshed."
Else
' loop through ONE based 2dim array
For i = LBound(a) To UBound(a)
If InStr(1, a(i, 1), Trim(s), vbTextCompare) Then
Me.ListBox2.AddItem ' add new listbox item
' enter 7 column values
For j = 1 To 7 ' ListBox2.List is ZERO based!!
Me.ListBox2.List(Me.ListBox2.ListCount - 1, j - 1) = a(i, j)
Next j
End If
Next i
Debug.Print "Time needed: " & Format(Timer - t, "0.00 ") & " seconds." & vbNewLine & _
"Search string """ & s & """:" & Me.ListBox2.ListCount & " items found."
End If
End If
If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True
End Sub
Note
My concern was to improve speed after empty string enters. So I concentrated on this part and left your further code nearly as it was, but did polish it up a little bit to make it more readable and used shorter names (e.g. ainstead of arrList). In order to control that, I added a Timer. BTW, I think you forgot some variable declarations.
Idea for further improvement of speed
If you want to speed up the normal string search, I'd suggest to use the following steps:
- use advanced filtering into a temporary worksheet,
- read the content into a new datafield array,
- write it back to the listbox via the described method and
- (delete the temporary worksheet afterwards).
Sure you'll find the right code to do so :-)
Additional hint
I recommend reading "Arrays and Ranges in VBA" by C.Pearson at http://www.cpearson.com/excel/ArraysAndRanges.aspx. For an example how to manipulate listboxes see also Excel VBA - avoid Error 1004 writing UF ListBox Array to Sheet
Good luck!
===================================================
Subsequent Edit (cf preceding comments as of 11/4-5)
This reedit combines not only the advantages of speeding up (A) empty string search (cf. my own answer above)
with (B) Dy Lee's very fast and highly appreciated approach (search string not empty),
but completes his solution by considering one liners and "zero" liners, too.
The recently suggested solution distinguishes between one liners and others
'' ===========================
'' B1 get one liners correctly
'' ===========================
' If ii = 1 Then
' Me.ListBox2.Column = vR
'' ===============================================
'' B2 get others with exception of 'zero' findings
'' ===============================================
' ElseIf ii > 1 Then
' Me.ListBox2.List = WorksheetFunction.Transpose(vR) ' not necessary, see below
' End If
but can be replaced by ONE code line only, as the ListBox.Column property retransposes the already
transposed vR array in ANY case correctly to a 2dim array
Me.ListBox2.Column = vR
whereas the ListBox.List property would do a double job in this case.
Additional hint:
It's worth mentioning, that populating listboxes via data field arrays helps to overcome the built-in **10 columns listbox limitation"
when using the AddItem method.
Summarized Code
The following - slightly modified - code should summarize all points and help other users to comprehend all improvements made (thx @Dy.Lee):
Dy Lee's solution refined and commented
Option Explicit
Private Sub TextBox1_Change()
' Note: based on Dy.Lee's approach including zero and one liners
' Changes: a) allows empty string search by one high speed code line
' b) writes back one liners correctly via .Column property instead of .List property (cf. comment)
' c) excludes zero findings to avoid error msg
' declare vars
Dim t As Double ' Timer
Dim s As String ' search string
Dim oSht As Worksheet ' work sheet
Dim r As Range
'=====
Dim a As Variant ' one based 2-dim data field array
Dim vR() As Variant ' transposed array
Dim i As Long ' rows
Dim j As Long ' columns
Dim ii As Long ' count findings
Dim jj As Long ' count listbox columns (.ColumnCount)
Dim n As Long ' last row
Dim nn As Long ' findings via filter function
t = Timer ' stop watch
s = Me.TextBox3 ' get search string
Set oSht = ThisWorkbook.Worksheets("Test")
' get last row number
n = oSht.Range("F" & oSht.Rows.count).End(xlUp).Row
if n = 1 then exit sub ' avoids later condition
ListBox2.ColumnCount = 7 ' (just for information)
jj = ListBox2.ColumnCount
ListBox2.Clear ' clear listbox elements
' write range to one based 2dim data field array
a = oSht.Range("F2:L" & n).Value2
' ========================
' A) EMPTY string findings ' show all items
' ========================
If Len(s) = 0 Then ' check if EMPTY string
' ====================================
' Trick: add complete items all in one
' ====================================
Me.ListBox2.List = a ' avoid loops, double speed
' ========================
' B) other actual findings
' ========================
Else '
' write results to redimmed and transposed array
For i = LBound(a) To UBound(a)
If InStr(1, a(i, 1), Trim(s), vbTextCompare) Then
ii = ii + 1
ReDim Preserve vR(1 To jj, 1 To ii)
For j = 1 To jj
vR(j, ii) = a(i, j)
Next j
End If
Next
' ==============================
' B1-B2) get any actual findings (retransposes both cases correctly to 2dim!)
' ==============================
If ii >=1 then ListBox2.Column = vR ' exclude "zero" lines
End If
If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True
' time needed
Debug.Print "Time needed: " & Format(Timer - t, "0.00 ") & " seconds." & _
" - Search string """ & s & """: " & Me.ListBox2.ListCount & " items found."
End Sub
