指定工作表多工作簿值搜索VBA代码无限冻结问题求助

需求与问题 #

需要用VBA遍历指定目录下的多个工作簿，仅在指定的重复工作表中搜索用户输入的BoM编码。当前代码运行无报错，但会导致Excel无限冻结，无法完成搜索任务。

用户提供的原代码 #

Sub SearchFolders()

Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xCol As Long
Dim i As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
Dim xAWB As Workbook
Dim xAWBStrPath As String
Dim xBol As Boolean
Set xAWB = ActiveWorkbook
'Set xWk = ActiveWorkbook.Worksheets("Civils*")
xAWBStrPath = xAWB.Path & "\" & xAWB.Name
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder"
If xFileDialog.Show = -1 Then
    xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
'xStrSearch = "1366P"
xStrSearch = InputBox("Please provide the BoM Code")
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets("SUMMARY")
xRow = 1
With xOut
    .Cells(xRow, 1) = "Workbook"
    .Cells(xRow, 2) = "Worksheet"
    .Cells(xRow, 3) = "Cell"
    .Cells(xRow, 4) = "Text in Cell"
    .Cells(xRow, 5) = "Values corresponding"
    Set xFso = CreateObject("Scripting.FileSystemObject")
    Set xFld = xFso.GetFolder(xStrPath)
    xStrFile = Dir(xStrPath & "\*.xls*")
    Do While xStrFile <> ""
        xBol = False
        If (xStrPath & "\" & xStrFile) = xAWBStrPath Then
            xBol = True
            Set xWb = xAWB
        Else
            Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            'Set xWk = Worksheets.Open("Civils Job Order")
        End If
        'For Each xWk In xWb.Worksheets("Civils Work Order")
         For Each xWk In xWb.Worksheets
            If xBol And (xWk.Name = .Name) Then
           'If xBol And (xWk.Name = "Civils Work Order" Or xWk.Name = "Cable Works Order") Then
            Else
            Set xFound = xWk.UsedRange.Find(xStrSearch)
            If Not xFound Is Nothing Then
                xStrAddress = xFound.Address
            End If
            Do
                If xFound Is Nothing Then
                    Exit Do
                Else
                    xCount = xCount + 1
                    xRow = xRow + 1
                    .Cells(xRow, 1) = xWb.Name
                    .Cells(xRow, 2) = xWk.Name
                    .Cells(xRow, 3) = xFound.Address
                    .Cells(xRow, 4) = xFound.Value
                    .Cells(xRow, 5).Range("A1").Value = xFound.EntireRow.Range("F1").Value
                End If
                Set xFound = xWk.Cells.FindNext(After:=xFound)
            Loop While xStrAddress <> xFound.Address
            End If
        Next
        If Not xBol Then
        xWb.Close (False)
        End If
        xStrFile = Dir
    Loop
    .Columns("A:E").EntireColumn.AutoFit
    
End With
MsgBox xCount & " cells have been found", , "BoM Calculator for VM Greenfield"
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

问题根源分析 #

1. 无限循环：当未找到匹配内容时，xStrAddress未初始化，后续循环条件xStrAddress <> xFound.Address会因xFound为Nothing引发逻辑错误，导致循环无法退出。
2. 无目标表过滤：原代码遍历工作簿所有工作表，未实现仅搜索指定表的需求。
3. 性能无优化：未禁用Excel事件、手动计算，后台操作易引发卡顿冻结。

修复后的代码 #

Sub SearchFolders()
    Dim xStrPath As String
    Dim xStrFile As String
    Dim xOut As Worksheet
    Dim xWb As Workbook
    Dim xWk As Worksheet
    Dim xRow As Long
    Dim xFound As Range
    Dim xStrAddress As String
    Dim xFileDialog As FileDialog
    Dim xUpdate As Boolean
    Dim xCount As Long
    Dim xAWB As Workbook
    Dim xAWBStrPath As String
    Dim xBol As Boolean
    ' 定义需要搜索的目标工作表名称，可按需修改
    Dim targetSheetNames As Variant
    targetSheetNames = Array("Civils Work Order", "Cable Works Order")
    
    Set xAWB = ActiveWorkbook
    xAWBStrPath = xAWB.Path & "\" & xAWB.Name
    
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    
    xStrSearch = InputBox("Please provide the BoM Code")
    If xStrSearch = "" Then Exit Sub ' 空输入直接退出
    
    ' 优化Excel运行性能
    xUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set xOut = Worksheets("SUMMARY")
    xRow = 1
    With xOut
        .Cells.Clear ' 清空历史结果（可选）
        .Cells(xRow, 1) = "Workbook"
        .Cells(xRow, 2) = "Worksheet"
        .Cells(xRow, 3) = "Cell"
        .Cells(xRow, 4) = "Text in Cell"
        .Cells(xRow, 5) = "Values corresponding"
        
        xStrFile = Dir(xStrPath & "\*.xls*")
        Do While xStrFile <> ""
            xBol = False
            If (xStrPath & "\" & xStrFile) = xAWBStrPath Then
                xBol = True
                Set xWb = xAWB
            Else
                Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
            End If
            
            ' 仅遍历指定的目标工作表
            Dim sheetName As Variant
            For Each sheetName In targetSheetNames
                On Error Resume Next ' 处理工作表不存在的情况
                Set xWk = xWb.Worksheets(sheetName)
                On Error GoTo ErrHandler
                If Not xWk Is Nothing Then
                    ' 跳过当前工作簿的SUMMARY表，避免重复搜索
                    If Not (xBol And xWk.Name = .Name) Then
                        ' 明确查找参数，避免默认值歧义
                        Set xFound = xWk.UsedRange.Find(xStrSearch, LookIn:=xlValues, LookAt:=xlWhole)
                        xStrAddress = ""
                        If Not xFound Is Nothing Then
                            xStrAddress = xFound.Address
                            Do
                                xCount = xCount + 1
                                xRow = xRow + 1
                                .Cells(xRow, 1) = xWb.Name
                                .Cells(xRow, 2) = xWk.Name
                                .Cells(xRow, 3) = xFound.Address
                                .Cells(xRow, 4) = xFound.Value
                                .Cells(xRow, 5).Value = xFound.EntireRow.Columns("F").Value ' 简化行F值获取
                                
                                Set xFound = xWk.Cells.FindNext(After:=xFound)
                            ' 循环终止条件：未找到内容 或 回到起始地址
                            Loop While Not xFound Is Nothing And xFound.Address <> xStrAddress
                        End If
                    End If
                    Set xWk = Nothing ' 释放对象
                End If
            Next sheetName
            
            If Not xBol Then
                xWb.Close (False)
            End If
            xStrFile = Dir
        Loop
        .Columns("A:E").EntireColumn.AutoFit
    End With
    
    MsgBox xCount & " cells have been found", , "BoM Calculator for VM Greenfield"
    
ExitHandler:
    ' 恢复Excel默认设置
    Application.ScreenUpdating = xUpdate
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    ' 释放所有对象
    Set xOut = Nothing
    Set xWk = Nothing
    Set xWb = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

关键修改说明 #

• 目标表过滤：通过targetSheetNames数组定义需搜索的工作表，仅遍历指定表，精准匹配需求。
• 修复无限循环：初始化xStrAddress，增加Not xFound Is Nothing循环条件，确保查找回到起始地址时退出。
• 性能优化：禁用事件、设置手动计算，减少后台操作，避免冻结卡顿。
• 容错处理：增加空输入判断、工作表不存在的异常处理，提升代码稳定性。
• 代码简化：优化行F值的获取方式，逻辑更清晰。

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