如何加快用户表单上列表框值的填充 excel
How to speed up filling of listbox values on userform excel
我有这段代码，它基本上过滤列表框中的值，因为 excel
中用户窗体的文本框中的值发生变化
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 秒才能完成从列表框中的 sheet 填充大约 8k 行 * 7 列数据，这是不可取的。有什么办法可以加快速度吗？
使用行源属性
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
将数据放入新数组后，用新数组设置listbox。
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
如何将所需时间减少到几乎为零
trick 加快从列表框中 sheet 填充大约 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。顺便说一句，我想你忘记了一些变量声明。
进一步提高速度的想法
如果你想加快正常的字符串搜索，我建议使用以下步骤：
- 使用高级过滤进入临时工作sheet,
- 将内容读入新的数据字段数组，
- 通过描述的方法将其写回列表框
- （之后删除临时工作sheet）。
您一定会找到正确的代码:-)
附加提示
我建议阅读 C.Pearson 在 http://www.cpearson.com/excel/ArraysAndRanges.aspx. For an example how to manipulate listboxes see also
的 "Arrays and Ranges in VBA"
祝你好运！
============================================= ======
后续编辑（参见 11/4-5 之前的评论）
这次重新编辑不仅结合了加快（A）空字符串搜索的优点（参见上面我自己的回答）
使用 (B) Dy Lee 非常快速和高度赞赏的方法（搜索字符串不为空），
但通过考虑一个衬垫和 "zero" 衬垫来完成他的解决方案。
最近建议的解决方案区分了一种衬垫和其他衬垫
'' ===========================
'' 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
我有这段代码，它基本上过滤列表框中的值，因为 excel
中用户窗体的文本框中的值发生变化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 秒才能完成从列表框中的 sheet 填充大约 8k 行 * 7 列数据，这是不可取的。有什么办法可以加快速度吗？
使用行源属性
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
将数据放入新数组后，用新数组设置listbox。
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
如何将所需时间减少到几乎为零
trick 加快从列表框中 sheet 填充大约 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。顺便说一句，我想你忘记了一些变量声明。
进一步提高速度的想法
如果你想加快正常的字符串搜索，我建议使用以下步骤：
- 使用高级过滤进入临时工作sheet,
- 将内容读入新的数据字段数组，
- 通过描述的方法将其写回列表框
- （之后删除临时工作sheet）。
您一定会找到正确的代码:-)
附加提示
我建议阅读 C.Pearson 在 http://www.cpearson.com/excel/ArraysAndRanges.aspx. For an example how to manipulate listboxes see also
祝你好运！
============================================= ======
后续编辑（参见 11/4-5 之前的评论）
这次重新编辑不仅结合了加快（A）空字符串搜索的优点（参见上面我自己的回答） 使用 (B) Dy Lee 非常快速和高度赞赏的方法（搜索字符串不为空）， 但通过考虑一个衬垫和 "zero" 衬垫来完成他的解决方案。
最近建议的解决方案区分了一种衬垫和其他衬垫
'' ===========================
'' 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