How to increase search speed for my vba userform? - vba

Question

I have a userform for search values (Alphanumerical). It works good. but take long time and sometime hung-up excel program.
In my userform, there are three textbox and three Listbox.
for searching my query, I can type anything to any text box. and all data from three Listbox are filtered and dependent to each other.
For Example: On Userform Initilize, Each Listbox Show 100 Item List.
and when I type anything to any search box (Text box) Item will be filtered from all listboxes.
(Sorry, Maybe my english and grammar are very weak.)
try to understand with this image.
Is there any way to increase my search speed?
My code is below: -
Option Explicit
Private Sub UserForm_Initialize()
Call loadList
Me.tbox_srch_ID.SetFocus
End Sub
Private Sub tbox_srch_ID_Keyup(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Me.tbox_srch_Word.Value = ""
Call loadList
End Sub
Private Sub tbox_srch_Word_Keyup(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Me.tbox_srch_Party.Value = ""
Call loadList
End Sub
Private Sub tbox_srch_Party_Keyup(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Me.tbox_srch_Word.Value = ""
Call loadList
End Sub
Sub loadList()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim baseArray() As Variant
Dim resultArray() As Variant
Dim IDArray() As Variant
Dim wordArray() As Variant
Dim PartyArray() As Variant
Dim counter As Long, i As Long
'On Error Resume Next
'Clear current list boxes
Me.lbox_ID.Clear
Me.lbox_Word.Clear
Me.lbox_Party.Clear
'Assign source list to an array, unfiltered
baseArray = Sheet2.Range("C2:E100001")
'Set a default value to filter match counter
counter = 0
'Iterate through the source list, if search term is found add item to result array
For i = LBound(baseArray) To UBound(baseArray)
If ((InStr(1, baseArray(i, 1), Me.tbox_srch_ID.Value, vbTextCompare) > 0 And Me.tbox_srch_Word.Value = "" And Me.tbox_srch_Party.Value = "") Or _
(InStr(1, baseArray(i, 2), Me.tbox_srch_Word.Value, vbTextCompare) > 0 And Me.tbox_srch_ID.Value = "" And Me.tbox_srch_Party.Value = "") Or _
(InStr(1, baseArray(i, 3), Me.tbox_srch_Party.Value, vbTextCompare) > 0 And Me.tbox_srch_ID.Value = "" And Me.tbox_srch_Word.Value = "")) Then
counter = counter + 1
ReDim Preserve resultArray(1 To 3, 1 To counter)
resultArray(1, counter) = baseArray(i, 1)
resultArray(2, counter) = baseArray(i, 2)
resultArray(3, counter) = baseArray(i, 3)
End If
Next i
'If there is at least one match, separate result array to two arrays and load them to the listboxes
If counter > 0 Then
ReDim IDArray(1 To UBound(resultArray, 2), 1 To 1)
ReDim wordArray(1 To UBound(resultArray, 2), 1 To 1)
ReDim PartyArray(1 To UBound(resultArray, 2), 1 To 1)
For i = LBound(resultArray, 2) To UBound(resultArray, 2)
IDArray(i, 1) = resultArray(1, i)
wordArray(i, 1) = resultArray(2, i)
PartyArray(i, 1) = resultArray(3, i)
Next i
Me.lbox_ID.List = IDArray
Me.lbox_Word.List = wordArray
Me.lbox_Party.List = PartyArray
End If
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Answer 1

Redim Preserve takes quite much resource, especially when running it 100K times. I'd collect the affected row numbers and store the data in an array in one step.
You should use a variable for checking upper boundary of For loop because Ubound is function and there's no need to evaluate it in every loop.
You should also revise the if condition, because it takes also a lot of resources. Please note that all conditions are evaluated (even if the bool logic would not require it) and you have 3 InStr (multiply with 100K).
Additionally, you check the textboxes for emptiness twice in each loop, for the 100K rows.
You might set an escape point somewhere, say when you find the first empty cell. No need to check empty area.
I would restucture it this way:
Dim RowColl as Collection
Set RowColl = New Collection
Dim boolID_Empty As Boolean, boolParty_Empty As Boolean, boolWord_Empty As Boolean
Dim boolSkip as Boolean
Dim iMax As Long
boolID_Empty = LenB(Me.tbox_srch_ID.Value) = 0 ' this is the fastest way to check for emptiness + check only once
boolParty_Empty = LenB(Me.tbox_srch_Party.Value) = 0
boolWord_Empty = LenB(Me.tbox_srch_Word.Value) = 0
counter = 0
iMax = UBound(baseArray)
For i = LBound(baseArray) To iMax
If LenB(baseArray(i, 1)) = 0 And LenB(baseArray(i, 2)) = 0 And LenB(baseArray(i, 3)) = 0 Then Exit For
boolSkip = True
If boolID_Empty And boolParty_Empty Then
If InStr(1, baseArray(i, 2), Me.tbox_srch_Word.Value, vbTextCompare) > 0 Then boolSkip = False
End If
If boolSkip And boolWord_Empty And boolParty_Empty Then
If InStr(1, baseArray(i, 1), Me.tbox_srch_ID.Value, vbTextCompare) > 0 Then boolSkip = False
End If
If boolSkip And boolID_Empty And boolWord_Empty Then
If InStr(1, baseArray(i, 3), Me.tbox_srch_Party.Value, vbTextCompare) > 0 Then boolSkip = False
End If
If Not boolSkip Then
RowColl.Add i ' add row index to a collection
End If
Next i
counter = RowColl.Count
ReDim resultArray(1 To 3, 1 To counter)
Dim v
i = 0
For Each v in RowColl
resultArray(1, i) = baseArray(v, 1)
resultArray(2, i) = baseArray(v, 2)
resultArray(3, i) = baseArray(v, 3)
i = i + 1
Next