VBA實時過濾器通過文本框的列表框

Question

我想根據寫在同一個用戶窗體中的文本框中的文本來過濾存儲在工作表中的值列表創建的列表框。

我的列表框有4或5列（取決於OptionField的選擇），我想搜索所有列寫入的文本。

示例：我在TextField中寫入「aaa」，並且列表框應基於列1或2或3或4或5包含「aaa」的所有行返回列表。

下面我的代碼，刷新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 

Answer 1

最後我能拿出的東西！

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 

Answer 2

我知道，答案是幾年老了......

但我想我會分享的解決方案，工作最適合我的，因爲過濾器速度極快，即使有幾千的項目在列表中。它是不是沒有「捕獲」，雖然： 它使用一個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