VBA工作表位置引用失效求助：多工作表复制后引用无响应

问题根源 #

1. 全局On Error Resume Next掩盖错误：代码开头的全局错误忽略会隐藏所有异常，包括复制多工作表后新工作簿的对象引用错误，导致位置引用失效时无报错，看起来像是被“忽略”。
2. 默认工作表删除逻辑有漏洞：复制第二个工作表后，新工作簿默认的Sheet1会被挤到后面，原代码直接按名称删除Sheet1可能因错误被跳过，导致工作表顺序与预期不符，位置引用失效。

修复步骤 #

1. 针对性处理错误，移除全局On Error Resume Next #

全局错误忽略是调试大忌，仅在检查工作表是否存在的局部使用错误捕获：

' 替换原错误处理逻辑
For i = 1 To ThisWorkbook.Worksheets.Count
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(i)
    On Error GoTo 0 ' 恢复正常错误捕获
    
    If ws Is Nothing Then
        Continue For ' 跳过不存在的工作表
    End If
    
    If IsDate(ws.Range("B2")) Then
        If Month(ws.Range("B2")) < Month(ThisWorkbook.ActiveSheet.Range("B2")) Then
            SheetsToBeSaved.Add i
        End If
    End If
Next i

2. 复制时直接获取工作表引用，避开位置依赖 #

复制工作表时直接返回新工作表的对象引用，后续操作无需依赖位置：

Dim newWs As Worksheet
For j = SheetsToBeSaved.Count - 1 To 0 Step -1
    Set newWs = ThisWorkbook.Sheets(SheetsToBeSaved(j)).Copy(Before:=wb.Sheets(1))
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(SheetsToBeSaved(j)).Delete
    Application.DisplayAlerts = True
    
    ' 如需操作新复制的工作表，直接使用newWs即可
    ' 示例：newWs.Range("A1").Value = "已迁移"
Next j

3. 安全删除新工作簿默认工作表 #

遍历确认默认Sheet1存在后再删除，避免因工作表顺序变化导致的错误：

Application.DisplayAlerts = False
For Each ws In wb.Worksheets
    If ws.Name = "Sheet1" Then
        ws.Delete
        Exit For
    End If
Next ws
Application.DisplayAlerts = True

4. 增加保存前的有效性检查 #

确保新工作簿有工作表后再执行保存逻辑，避免空工作簿报错：

If wb.Worksheets.Count > 0 Then
    PrevMonth = MonthName(Month(wb.Worksheets(1).Range("B2")))
    wb.SaveAs "L:\filesrvr\Dominique\Time Reporting\Daily Timesheets\" & PrevMonth, FileFormat:=52
Else
    MsgBox "没有符合条件的工作表被迁移，无法保存！"
    wb.Close SaveChanges:=False
End If

完整修复代码 #

Dim SheetsToBeSaved As ArrayList
Set SheetsToBeSaved = New ArrayList
Dim i As Integer
Dim j As Integer
Dim wb As Workbook
Set wb = Workbooks.Add
Dim PrevMonth As String
Dim ws As Worksheet
Dim newWs As Worksheet

' 收集符合条件的工作表索引
For i = 1 To ThisWorkbook.Worksheets.Count
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(i)
    On Error GoTo 0
    
    If ws Is Nothing Then
        Continue For
    End If
    
    If IsDate(ws.Range("B2")) Then
        If Month(ws.Range("B2")) < Month(ThisWorkbook.ActiveSheet.Range("B2")) Then
            SheetsToBeSaved.Add i
        End If
    End If
Next i

' 迁移工作表到新工作簿
For j = SheetsToBeSaved.Count - 1 To 0 Step -1
    Set newWs = ThisWorkbook.Sheets(SheetsToBeSaved(j)).Copy(Before:=wb.Sheets(1))
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(SheetsToBeSaved(j)).Delete
    Application.DisplayAlerts = True
Next j

' 删除新工作簿默认Sheet1
Application.DisplayAlerts = False
For Each ws In wb.Worksheets
    If ws.Name = "Sheet1" Then
        ws.Delete
        Exit For
    End If
Next ws
Application.DisplayAlerts = True

' 保存新工作簿
If wb.Worksheets.Count > 0 Then
    PrevMonth = MonthName(Month(wb.Worksheets(1).Range("B2")))
    wb.SaveAs "L:\filesrvr\Dominique\Time Reporting\Daily Timesheets\" & PrevMonth, FileFormat:=52
Else
    MsgBox "未找到符合条件的工作表，取消保存！"
    wb.Close SaveChanges:=False
End If

' 释放对象
SheetsToBeSaved.Clear
Set SheetsToBeSaved = Nothing
Set wb = Nothing
Set ws = Nothing
Set newWs = Nothing

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