Excel VBA文本框搜索列表框卡顿崩溃问题求助

我有一个名为“L 403”的Excel工作表，A列为搜索值所在列，需从B列获取对应结果。需求为：在文本框txtreg中输入值时，列表框txtledglist显示1至6条对应结果。现有VBA代码在仅1条结果时运行正常，但存在多结果时耗时超5分钟甚至崩溃、清空搜索值时也会崩溃的问题，排查发现代码持续运行。现有代码如下：

Private Sub txtreg_Change()


    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lookupValue As String
    Dim results() As Variant
    Dim rng As Range
    Dim cell As Range
    Dim index As Long
    Dim count As Long
    

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("L 403")
    

    lookupValue = txtreg.Value
    
    txtledglist.Clear
    
    Set rng = ws.Range("A:B")
    On Error Resume Next
    Set cell = rng.Columns(1).Find(What:=lookupValue, LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0
    
    If Not cell Is Nothing Then
        count = 0
        Do
            count = count + 1
            ' Find the next match
            Set cell = rng.Columns(1).FindNext(cell)
        Loop While Not cell Is Nothing And cell.Address <> rng.Columns(1).Find(What:=lookupValue, After:=cell, LookIn:=xlValues, LookAt:=xlWhole).Address
        
        ReDim results(1 To count)
        
        Set cell = rng.Columns(1).Find(What:=lookupValue, LookIn:=xlValues, LookAt:=xlWhole)
        
        index = 1
        Do
            results(index) = rng.Columns(2).Cells(cell.Row - rng.Cells(1).Row + 1).Value ' Adjusting for header row
            index = index + 1
            Set cell = rng.Columns(1).FindNext(cell)
        Loop While Not cell Is Nothing And cell.Address <> rng.Columns(1).Find(What:=lookupValue, After:=cell, LookIn:=xlValues, LookAt:=xlWhole).Address
        
        txtledglist.List = results
       
    End If

End Sub

原代码的核心问题：

• 循环逻辑错误：每次循环重复调用Find方法，循环条件判断混乱，多结果时直接触发无限循环，导致资源耗尽崩溃
• 空值处理缺失：清空搜索值时，lookupValue为空字符串，Find会匹配所有空单元格，进一步加剧循环问题
• 效率极低：遍历整列A:B而非实际数据区域，无用运算量极大

Private Sub txtreg_Change()
    Dim ws As Worksheet
    Dim lookupValue As String
    Dim results As Collection
    Dim lastRow As Long
    Dim i As Long
    Dim maxResults As Long
    
    ' 设置最大显示结果数
    maxResults = 6
    Set results = New Collection
    Set ws = ThisWorkbook.Sheets("L 403")
    lookupValue = Trim(txtreg.Value)
    
    txtledglist.Clear
    
    ' 空搜索值直接退出，避免无意义遍历
    If lookupValue = "" Then Exit Sub
    
    ' 获取A列实际数据的最后一行，缩小遍历范围
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历数据区域，收集匹配结果（最多6条）
    On Error Resume Next ' 忽略重复项报错
    For i = 1 To lastRow
        If ws.Cells(i, "A").Value = lookupValue Then
            results.Add ws.Cells(i, "B").Value
            ' 达到上限立即停止遍历
            If results.Count >= maxResults Then Exit For
        End If
    Next i
    On Error GoTo 0
    
    ' 将结果写入列表框
    If results.Count > 0 Then
        Dim arr() As Variant
        ReDim arr(1 To results.Count)
        For i = 1 To results.Count
            arr(i) = results(i)
        Next i
        txtledglist.List = arr
    End If
End Sub

• 避免无限循环：改用普通For循环遍历实际数据区域，逻辑清晰无死循环风险
• 大幅提升效率：仅遍历A列有数据的部分，而非整列，运算量骤减
• 处理空值情况：搜索值为空时直接退出，避免无效遍历
• 限制结果数量：最多收集6条结果，符合需求同时减少不必要运算
• 简化逻辑：用Collection存储结果，摒弃原代码中重复且混乱的Find操作

内容的提问来源于stack exchange，提问作者Funny Memo Ms