VBA查找循环异常：仅匹配首个结果或无限循环的修复方案

问题根源分析 #

1. 仅复制首个匹配项就停止：原代码中If Not foundCell Is Nothing Then Exit Do逻辑错误，在找到下一个匹配项后直接退出循环，导致只处理第一个结果。
2. 替换后陷入无限循环：使用Loop While Not foundCell is Nothing时，FindNext遍历到最后一个匹配项后会回到第一个匹配项位置，循环往复永远不会返回Nothing，因此触发无限循环。

修复方案 #

核心思路是记录第一个匹配单元格的地址，每次调用FindNext后检查是否回到起始地址，以此作为循环终止条件。同时针对27万行大数据量优化代码性能：

Sub SearchForWord()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim searchSheet As Worksheet: Set searchSheet = wb.Sheets("Search")
    Dim sws As Worksheet: Set sws = wb.Sheets("Outillages")
    Dim sCols() As Variant: sCols = Array("BC", "BD", "BN", "BO")
    Dim dCols() As Variant: dCols = Array("B", "C", "D", "E")
    Dim SearchValue As Variant
    Dim foundCell As Range
    Dim firstFoundAddr As String ' 记录第一个匹配单元格的地址
    Dim i As Long
    Dim dRow As Long: dRow = 6
    
    ' 关闭Excel冗余功能提升大数据处理速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    SearchValue = ActiveSheet.Range("B3").Value
    
    If Len(SearchValue) > 0 Then
        Set foundCell = sws.Columns("BC").Find(What:=SearchValue, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not foundCell Is Nothing Then
            firstFoundAddr = foundCell.Address ' 保存第一个匹配地址
            Do
                ' 批量复制对应列数据
                For i = LBound(sCols) To UBound(sCols)
                    searchSheet.Cells(dRow, dCols(i)).Value = sws.Cells(foundCell.Row, sCols(i)).Value
                Next i
                dRow = dRow + 1
                
                ' 查找下一个匹配项
                Set foundCell = sws.Columns("BC").FindNext(foundCell)
                
                ' 终止条件：回到第一个匹配地址或无匹配项
            Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddr
            
            MsgBox "共复制 " & dRow - 6 & " 条匹配数据"
        Else
            MsgBox "未找到匹配值"
        End If
    Else
        MsgBox "请输入搜索参考值"
    End If
    
    ' 恢复Excel默认功能
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

关键修改说明 #

• 新增firstFoundAddr变量记录首个匹配单元格地址，彻底解决无限循环问题。
• 调整循环终止条件为Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddr，确保遍历所有匹配项后自动停止。
• 移除冗余变量，简化代码结构。
• 添加性能优化代码，针对27万行数据大幅提升运行效率。
• 优化提示信息，显示实际复制的匹配条数，增强直观性。

内容的提问来源于stack exchange，提问作者AmbRenoTest