Excel VBA复制工作表：Cells.Replace执行后子过程异常退出问题排查

问题 #

我正在编写一个VBA子过程，用于将一个工作簿中的工作表复制到另一个工作簿，替换目标工作簿中的同名工作表。目标工作簿的其他工作表中可能存在引用该待刷新工作表的公式。

我已实现了一个版本，通过复制源工作表的所有单元格到目标工作表，但更希望整体复制工作表。具体步骤如下：

• 复制工作表，由于原工作表仍存在，Excel会自动分配新名称；
• 使用Cells.Replace更新所有工作表中的公式，使其引用新工作表；
• 删除目标工作簿中的旧版本工作表；
• 将新工作表重命名为原名称，Excel会自动处理公式中的引用更名。

我编写了如下代码，但发现执行Cells.Replace语句后，子过程似乎退出了。该语句可正常工作，但仅更新了第一个工作表的公式，后续工作表的公式未更新，删除旧表和重命名新表的语句也未执行。若手动执行后续步骤，可达到预期效果。请问Cells.Replace语句执行正常但无法返回子过程继续执行的原因是什么？

Sub TestReplaceSheets2()

Dim ws_to As Worksheet, ws_from As Worksheet
Dim wb_to As Workbook
Dim iSht As Integer
Dim ws As Worksheet
Dim newName As String, oldName As String
Dim sTestb As String, sTesta As String
Dim bTest As Boolean

    Set ws_from = ThisWorkbook.Sheets("01-18-2023")
    Set ws_to = Workbooks("Book1").Sheets("01-18-2023")
    
    Set wb_to = ws_to.Parent
    oldName = ws_to.Name
    
    sTestb = wb_to.Sheets(1).Range("A1").Formula 'For verification purposes only
    
    iSht = ws_to.Index
    
    ws_from.Copy After:=wb_to.Sheets(iSht)
    
    newName = wb_to.Sheets(iSht + 1).Name
    
    For Each ws In wb_to.Worksheets
        If ws.Name <> oldName And ws.Name <> newName Then
          ws.Cells.Replace What:=ws_to.Name, Replacement:=newName, LookAt:= _
            xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End If

'       It never makes it here - it updates the formulas in the 1st ws , but not the 2nd

    Next ws
    
    ws_to.Delete
    wb_to.Sheets(newName).Name = oldName
    
    sTesta = wb_to.Sheets(1).Range("A1").Formula 'For verification purposes only
    
    bTest = sTesta = sTestb 'For verification purposes only

End Sub

原因及解决方法 #

核心原因 #

Cells.Replace操作会触发Excel的工作表事件（比如Change或Calculate事件），如果你的工作簿中存在绑定这些事件的宏，且宏里包含Exit Sub、End这类终止语句，就会直接中断当前的主过程；另外，事件触发时弹出的未处理警告弹窗，也会卡住代码执行流程，导致后续步骤无法运行。

同时，直接遍历动态的wb_to.Worksheets集合时，复制新工作表会改变集合的结构，也可能导致循环提前终止。

解决步骤 #

1. 禁用事件触发：在执行关键操作前关闭Excel的事件响应，避免意外中断。
2. 改用数组遍历工作表：先将工作表名称存入数组，再遍历数组，规避动态集合变化带来的问题。
3. 添加错误捕获：确保过程出错时能恢复Excel的正常状态。

修改后的代码 #

Sub TestReplaceSheets2()

Dim ws_to As Worksheet, ws_from As Worksheet
Dim wb_to As Workbook
Dim iSht As Integer
Dim wsNames() As String
Dim idx As Integer
Dim newName As String, oldName As String
Dim sTestb As String, sTesta As String
Dim bTest As Boolean

    ' 禁用事件和屏幕更新，提升效率并避免中断
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    On Error GoTo Cleanup ' 错误捕获
    
    Set ws_from = ThisWorkbook.Sheets("01-18-2023")
    Set ws_to = Workbooks("Book1").Sheets("01-18-2023")
    
    Set wb_to = ws_to.Parent
    oldName = ws_to.Name
    
    sTestb = wb_to.Sheets(1).Range("A1").Formula
    
    iSht = ws_to.Index
    
    ws_from.Copy After:=wb_to.Sheets(iSht)
    newName = wb_to.Sheets(iSht + 1).Name
    
    ' 将工作表名称存入数组，避免遍历动态集合
    ReDim wsNames(1 To wb_to.Worksheets.Count)
    For idx = 1 To wb_to.Worksheets.Count
        wsNames(idx) = wb_to.Worksheets(idx).Name
    Next idx
    
    ' 遍历数组更新公式
    For idx = 1 To UBound(wsNames)
        Set ws = wb_to.Worksheets(wsNames(idx))
        If ws.Name <> oldName And ws.Name <> newName Then
            ws.Cells.Replace What:=oldName, Replacement:=newName, LookAt:= _
                xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
        End If
    Next idx
    
    ws_to.Delete
    wb_to.Sheets(newName).Name = oldName
    
    sTesta = wb_to.Sheets(1).Range("A1").Formula
    bTest = sTesta = sTestb

Cleanup:
    ' 恢复事件和屏幕更新
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then
        MsgBox "执行出错: " & Err.Description, vbExclamation
    End If
End Sub

额外说明 #

• 禁用事件是关键：Application.EnableEvents = False会阻止Replace操作触发工作表的各类事件，避免事件宏中断主过程。
• 数组遍历更稳定：工作表集合在复制/删除后会动态变化，提前存储名称到数组能保证遍历所有目标工作表。
• 错误处理保障恢复：无论过程是否出错，都会恢复Excel的事件响应和屏幕更新，避免程序处于异常状态。

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