我有这个代码基本上过滤列表框中的值，因为excel中userform上文本框中的值发生了变化
Private Sub TextBox1_Change()
Dim sht As Worksheet
Dim rng1 As Range
Set sht = Sheet5
Set rng1 = sht.Range("F2:F" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row)
ListBox2.ColumnCount = 7
'=====
Dim i As Long
Dim arrList As Variant
Me.ListBox2.Clear
If sht.Range("F" & sht.Rows.Count).End(xlUp).Row > 1 Then
arrList = sht.Range("F2:L" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row).Value2
For i = LBound(arrList) To UBound(arrList)
If InStr(1, arrList(i, 1), Trim(Me.TextBox1.Value), vbTextCompare) Then
liste = ListBox2.ListCount
Me.ListBox2.AddItem
Me.ListBox2.List(liste, 0) = arrList(i, 1)
Me.ListBox2.List(liste, 1) = arrList(i, 2)
Me.ListBox2.List(liste, 2) = arrList(i, 3)
Me.ListBox2.List(liste, 3) = arrList(i, 4)
Me.ListBox2.List(liste, 4) = arrList(i, 5)
Me.ListBox2.List(liste, 5) = arrList(i, 6)
Me.ListBox2.List(liste, 6) = arrList(i, 7)
End If
Next i
End If
If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True
End Sub
它完美地工作，除非我将值从某些内容更改为空白，即空白时需要大约4到5秒才能完成从列表框中的工作表中填充大约8k行* 7列数据，这是不可取的。我们有什么方法可以加快速度吗？
答案 0 :(得分：3)
将数据放入新数组后，按新数组设置列表框。
Private Sub TextBox1_Change()
Dim sht As Worksheet
Dim rng1 As Range
Dim vR() As Variant
Set sht = Sheet5
Set rng1 = sht.Range("F2:F" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row)
ListBox2.ColumnCount = 7
'=====
Dim i As Long
Dim arrList As Variant
Me.ListBox2.Clear
If sht.Range("F" & sht.Rows.Count).End(xlUp).Row > 1 Then
arrList = sht.Range("F2:L" & sht.Range("F" & sht.Rows.Count).End(xlUp).Row).Value2
For i = LBound(arrList) To UBound(arrList)
If InStr(1, arrList(i, 1), Trim(Me.TextBox1.Value), vbTextCompare) Then
n = n + 1
ReDim Preserve vR(1 To 7, 1 To n)
For j = 1 To 7
vR(j, n) = arrList(i, j)
next j
End If
Next
Me.ListBox2.List = WorksheetFunction.Transpose(vR)
End If
If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True
End Sub
答案 1 :(得分：1)
如何将所需时间缩短至接近零
技巧加快填充大约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在http://www.cpearson.com/excel/ArraysAndRanges.aspx阅读“VBA中的阵列和范围”。有关如何操作列表框的示例，请参阅Excel VBA - avoid Error 1004 writing UF ListBox Array to Sheet
祝你好运！=============================================== ====
后续编辑（参见11 / 4-5之前的评论）
这个reedit不仅结合了加速（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方法时。
汇总代码
以下 - 稍加修改 - 代码应该总结所有要点并帮助其他用户理解所做的所有改进（thx @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
答案 2 :(得分：-1)
使用rowsource属性
Option Explicit
Private Sub TextBox1_Change()
Dim sht As Worksheet
Set sht = Sheet1
Dim dataEnd as long
dataEnd = sht.Range("F" & sht.Rows.Count).End(xlUp).Row
Dim rng1 As Range
Set rng1 = sht.Range("F2:F" & dataEnd)
ListBox2.ColumnCount = 7
ListBox2.ColumnWidths = "30 pt;30 pt;30 pt;30 pt;30 pt;30 pt;30 pt"
'=====
Dim i As Long
Dim listData As Range
' Me.ListBox2.Clear
If dataEnd > 1 Then
Set listData = sht.Range("F2:L" & dataEnd)
Me.ListBox2.RowSource = Sheet2.Name & "!" & listData.Address ' this fills the listbox
End If
If Me.ListBox2.ListCount = 1 Then Me.ListBox2.Selected(0) = True
End Sub