如何在excel VBA用户窗体中加速搜索结果？

以下代码用于列表框中的搜索值，列表框的数据连接到名为（车辆中）的表 代码正在运行，但需要花费太多的时间，有时还会挂断excel。并将excel设置为“无响应”。 我不知道如何加快我的搜索速度。 也没有发现错误

Private Sub UserForm_Initialize()
 TextBox1.SetFocus
 lstSearchVehicle.ColumnCount = 23
         SearchVehicle.lstSearchVehicle.ColumnWidths = "15,35,55,50,50,60,60,50,50,0,0,60,60,60,0,60,60,40,35,60,45,60,60"
 lstSearchVehicle.List = Sheets("VEHICLE IN").Range("A1:W101" & Sheets("VEHICLE IN").Cells(Rows.Count, 1).End(xlUp).Row).Value
 TextBox1.SetFocus
End Sub
Private Sub lstSearchVehicle_Change()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

On Error Resume Next
 Dim j As Long, testString As String
 testString = "*" & TextBox1.Text & "*"
 With Me.lstSearchVehicle
 .List = Sheets("VEHICLE IN").Range("A1:W101" & Sheets("VEHICLE IN").Cells(Rows.Count, 1).End(xlUp).Row).Value
 If .ListIndex = -1 And Len(TextBox1.Text) Then
 For j = .ListCount - 1 To 0 Step -1
      If (Not (LCase(.List(j, 0)) Like testString) And (Not (LCase(.List(j, 1)) Like testString))) _
 And (Not (LCase(.List(j, 2)) Like testString) And (Not (LCase(.List(j, 3)) Like testString))) _
 And (Not (LCase(.List(j, 4)) Like testString) And (Not (LCase(.List(j, 5)) Like testString))) _
 And (Not (LCase(.List(j, 6)) Like testString) And (Not (LCase(.List(j, 7)) Like testString))) _
 And (Not (LCase(.List(j, 8)) Like testString) And (Not (LCase(.List(j, 9)) Like testString))) _
 And (Not (LCase(.List(j, 10)) Like testString) And (Not (LCase(.List(j, 11)) Like testString))) _
 And (Not (LCase(.List(j, 12)) Like testString) And (Not (LCase(.List(j, 13)) Like testString))) _
 And (Not (LCase(.List(j, 14)) Like testString) And (Not (LCase(.List(j, 15)) Like testString))) _
 And (Not (LCase(.List(j, 16)) Like testString) And (Not (LCase(.List(j, 17)) Like testString))) _
 And (Not (LCase(.List(j, 18)) Like testString) And (Not (LCase(.List(j, 19)) Like testString))) _
 And (Not (LCase(.List(j, 20)) Like testString) And (Not (LCase(.List(j, 21)) Like testString))) _
 And (Not (LCase(.List(j, 22)) Like testString)) Then .RemoveItem j
 Next j
 End If
 End With
     
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
End Sub

Private Sub TextBox1_Change()
 lstSearchVehicle_Change
End Sub

---

这个代码看起来有点奇怪

首先，你确定这个范围定义是你想要的吗？它取最后一行并在该行前面加上“101”。所以，如果最后一行是12345，则从10112345行中获取值

Sheets("VEHICLE IN").Range("A1:W101" & Sheets("VEHICLE IN").Cells(Rows.Count, 1).End(xlUp).Row)

其次，您是否知道，每当文本框发生更改时，就会调用listbox加载例程？这可能是您想要的，但如果您的数据集很大，则可能会导致一些挂起。手动调用事件处理程序例程也不太理想——就像您在textbox事件处理程序中所做的那样

第三，除非你真的知道处理器“引擎盖下”发生了什么，否则从你正在循环的对象中移除项目并不理想

上面的所有要点要么会导致您的例程比预期的要大，要么您会发现很难在这些事件处理程序中进行跟踪

我不打算为您编写代码，但它看起来更像这样：

Private Const LISTBOX_COL_COUNT As Long = 23

Private Sub TextBox1_Change()
    PopulateListbox "*" & TextBox1.Text & "*"
End Sub

Private Sub UserForm_Initialize()

    With ListBox1
        .ColumnCount = LISTBOX_COL_COUNT
        .ColumnWidths = "15,35,55,50,50,60,60,50,50,0,0,60,60,60,0,60,60,40,35,60,45,60,60"
    End With
    
    PopulateListbox
End Sub

Private Sub PopulateListbox(Optional removeItem As String = vbNullString)
    Dim rng As Range
    Dim v() As Variant, listItems() As Variant
    Dim rowNum As Variant
    Dim rowList As Collection
    Dim r As Long, c As Long
    Dim itemText As String
    Dim isMatch As Boolean
    
    'Define the target range.
    With Worksheets("Sheet1")
        Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, LISTBOX_COL_COUNT)
    End With
    
    'Read the values into an array.
    v = rng.Value2
    
    'If no removals are required then just populate with the read array.
    If removeItem = vbNullString Then
        ListBox1.List = v
        Exit Sub
    End If
    
    'For removals find the list of matching rows in the array.
    Set rowList = New Collection
    For r = LBound(v, 1) To UBound(v, 1)
        isMatch = False
        For c = LBound(v, 2) To UBound(v, 2)
            itemText = LCase(CStr(v(r, c)))
            If itemText Like removeItem Then
                isMatch = True
                Exit For
            End If
        Next
        If isMatch Then rowList.Add r
    Next
    
    'Size the new list array, based on matching items.
    ReDim listItems(1 To rowList.Count, 1 To LISTBOX_COL_COUNT)
    
    'Copy the matchings rows to the new array.
    r = 1
    For Each rowNum In rowList
        For c = LBound(v, 2) To UBound(v, 2)
            listItems(r, c) = v(rowNum, c)
        Next
        r = r + 1
    Next
    
    'Populate the listbox with the new array.
    ListBox1.List = listItems
    
End Sub

---

也许是

WorksheetFunction.CountIfs

而不是循环。或者将数据批量加载到一个变量数组中，并循环该数组而不是在工作表上循环范围。先生，请您帮我做一下。我不知道VBA。亲爱的Scott Craner先生，如何将数据批量加载到变量数组？我是VBA的新手。用户表单快速加载数据。但当我在textbox1中键入内容时，它会给我一个运行时9错误，下标超出范围，其中ReDim是start（ReDim listItems（1到rowList.Count，1到LISTBOX\u COL\u Count））。在我的Userform中，只有两个对象可用。1是文本框1，2是列表框1。数据源是sheet1列范围A:W（总共23列），带有标题行。是的，这只是框架代码。您需要添加处理奇怪情况的代码。该错误表示没有匹配项，因此需要处理

rowList.Count=0

案例。我不确定您是否知道，但我们不会在这些答案中编写生产代码，我们会给您显示原则的代码。试着理解每一行代码，然后调整它以满足您的需要。脱帽致敬，令人兴奋的解决方案。我认为这个解决方案是在工作表中搜索值的最好、最快的方法。真的，你是真正的Excel高手Ambie先生。谢谢你提供了最好的解决方案@Ambie。我发现了一个小问题（实际上这不是一个真正的问题）。当我加载用户表单时，列表框列宽与此值一致（ListBox1.ColumnWidths=“20,35,70,50,50,60,60,50,0,0,60,60,60,60,0,60,60,40,35,60,45,60,60”），但当加载搜索结果时，列宽可能会更改为默认值。因此，某些值不清晰可见。