如何提高我的 vba 用户表单的搜索速度？

Question

我有一个用于搜索值（字母数字）的用户表单。它运作良好。但需要很长时间，有时会挂起 excel 程序。

在我的用户表单中，有三个文本框和三个列表框。

为了搜索我的查询，我可以在任何文本框中输入任何内容。并且来自三个 Listbox 的所有数据都经过过滤并相互依赖。 例如：在用户窗体初始化时，每个列表框显示 100 个项目列表。 当我在任何搜索框（文本框）中输入任何内容时，项目将从所有列表框中过滤掉。

（对不起，我的英语和语法可能很弱。）

试着用这张图来理解。

有什么方法可以提高我的搜索速度？

我的代码如下：-

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 占用大量资源，尤其是在运行 100K 次时。我会一步一步收集受影响的行号并将数据存储在一个数组中。

您应该使用一个变量来检查 For 循环的上限，因为 Ubound 是函数，不需要在每个循环中都对其进行评估。

您还应该修改 if 条件，因为它也需要大量资源。请注意，所有条件都被评估（即使布尔逻辑不需要它）并且您有 3 个InStr（乘以 100K）。 此外，对于 100K 行，您在每个循环中检查两次文本框是否为空。

你可以在某个地方设置一个逃生点，比如当你找到第一个空单元格时。无需检查空白区域。

我会这样重构它：

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