如何将所需时间减少到几乎为零
技巧加快从列表框中的工作表中填充大约 8k 行 * 7 列数据不是每次都使用AddItem，而是设置整个数组到列表框：
Me.ListBox2.List = a
检查搜索字符串s是否为空后
If Len(s) = 0 Then
代码
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
注意
我关心的是在空字符串进入后提高速度。所以我专注于这部分，并几乎保留了您的进一步代码，但确实对其进行了一些润色以使其更具可读性并使用更短的名称（例如a而不是arrList）。为了控制它，我添加了一个Timer。顺便说一句，我想你忘记了一些变量声明。
进一步提高速度的想法
如果你想加快正常的字符串搜索，我建议使用以下步骤：
- 在临时工作表中使用高级过滤，
- 将内容读入新的数据域数组，
- 通过所描述的方法将其写回列表框并
- （之后删除临时工作表）。
当然，您会找到正确的代码：-)
附加提示
我建议阅读 C.Pearson 的“VBA 中的数组和范围”http://www.cpearson.com/excel/ArraysAndRanges.aspx。有关如何操作列表框的示例，另请参阅 Excel VBA - avoid Error 1004 writing UF ListBox Array to Sheet
祝你好运！
================================================ ====
后续编辑（参见 11/4-5 之前的 cmets）
此重新编辑不仅结合了加快 (A) 空字符串搜索的优点（参见上面我自己的答案）
使用 (B) Dy Lee 非常快速且高度赞赏的方法（搜索字符串不为空），
但也通过考虑一个衬垫和“零”衬垫来完成他的解决方案。
最近提出的解决方案区分了一个衬垫和其他衬垫
'' ===========================
'' 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
但只能由一个代码行替换，因为ListBox.Column 属性重新转置了已经
在任何情况下都正确地将 vR 数组转置为 2dim 数组
Me.ListBox2.Column = vR
而ListBox.List 属性在这种情况下会起到双重作用。
附加提示：
值得一提的是，通过数据字段数组填充列表框有助于克服内置的**10列列表框限制”
当使用AddItem 方法时。
摘要代码
以下 - 稍作修改 - 代码应总结所有要点并帮助其他用户理解所做的所有改进（感谢@Dy.Lee）：
Dy Lee 的解决方案提炼和评论
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