VBA 通过文本框实时过滤列表框
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/17060306/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA realtime filter Listbox through Textbox
提问by Noldor130884
I would like to filter a Listbox created from a list of values stored in a worksheet depending on text written in a textbox contained in the same userform.
我想过滤从存储在工作表中的值列表创建的列表框，具体取决于写入包含在同一用户表单中的文本框中的文本。
My Listbox has 4 or 5 columns (depending on OptionField selection) and I would like to search all the columns for the text written.
我的列表框有 4 或 5 列（取决于 OptionField 选择），我想在所有列中搜索所写的文本。
Example: I write "aaa" in TextField and the Listbox should return a list based on all the lines whose column 1 or 2 or 3 or 4 or 5 contain "aaa".
示例：我在 TextField 中写入“aaa”，并且列表框应返回基于其第 1、2、3、4 或 5 列包含“aaa”的所有行的列表。
Below my code to refresh the list on OptionField selection (this code does not produce any error, it is just to show how I create my list):
在我的代码下方刷新 OptionField 选择列表（此代码不会产生任何错误，它只是为了展示我如何创建我的列表）：
Sub RefreshList()
Dim selcell, firstcell As String
Dim k, i As Integer
Dim r as long
i = 0
k = 0
' reads parameters from hidden worksheet
If Me.new_schl = True Then
firstcell = Cells(3, 4).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 2
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 7).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 7).Address(0, 0)
With Me.ListBox1
.ColumnCount = 4
.ColumnWidths = "50; 80; 160; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
Else
firstcell = Cells(3, 11).Address
selcell = firstcell
Do Until IsEmpty(Range("" & selcell & "")) And i = 11
If IsEmpty(Range("" & selcell & "")) Then i = i + 1
k = k + 1
selcell = Cells(1 + k, 15).Address(0, 0)
Loop
k = k - 1
selcell = Cells(1 + k, 15).Address(0, 0)
With Me.ListBox1
.ColumnCount = 5
.ColumnWidths = "40; 40; 160; 40; 40"
.RowSource = ""
Set MyData = Range("" & firstcell & ":" & selcell & "")
.List = MyData.Cells.Value
For r = .ListCount - 1 To 0 Step -1
If .List(r, 3) = "" Or .List(r, 3) = "0" Then
.RemoveItem r
End If
Next r
End With
End If
End Sub
采纳答案by Noldor130884
Finally I could come out with something!
我终于可以拿出点东西了！
Sub Filter_Change()
Dim i As Long
Dim Str As String
Str = Me.Filter.Text
Me.RefreshList
If Not Str = "" Then
With Me.ListBox1
For i = .ListCount - 1 To 0 Step -1
If InStr(1, LCase(.List(i, 0)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 1)), LCase(Str)) = 0 And _
InStr(1, LCase(.List(i, 2)), LCase(Str)) = 0 And InStr(1, LCase(.List(i, 3)), LCase(Str)) = 0 Then
.RemoveItem i
End If
Next i
End With
End If
End Sub
回答by Tomaski
I know, the answer is couple of years old...
我知道，答案是几年前的...
But I thought I'd share solution that works the best for me, because the filter is blazing fast even when there are thousands of items in the list. It is not without a "catch", though: it uses a Dictionary object
但我想我会分享最适合我的解决方案，因为即使列表中有数千个项目，过滤器也能快速运行。但是，它并非没有“捕获”：它使用 Dictionary 对象
Option Explicit
Dim myDictionary As Scripting.Dictionary
Private Sub fillListbox()
Dim iii As Integer
Set myDictionary = New Scripting.Dictionary
' this, here, is just a "draft" of a possible loop
' for filling in the dictionary
For iii = 1 To RANGE_END
If Not myDictionary.Exists(UNIQUE_VALUE) Then
myDictionary.Add INDEX, VALUE
End If
Next
myListbox.List = myDictionary .Items
End Sub
Private Sub textboxSearch_Change()
Dim Keys As Variant
Keys = myDictionary .Items
myListbox.List = Filter(Keys, textboxSearch.Text, True, vbTextCompare)
End Sub
Private Sub UserForm_Initialize()
Call fillListbox
End Sub
