跨工作簿复制数据时VBA子程序在Copy步骤异常退出问题

核心问题 #

1. 未限定单元格范围的工作表归属
   代码里Range([A39], [H39].End(xlDown))中的[A39]和[H39]没有指定所属工作表，默认会指向当前活动工作表，而非你要复制的源工作表wbk.Sheets(wb_Name)。一旦活动表不是目标源表，就会触发隐性错误，导致子程序直接退出却不报错。

2. 依赖ActiveSheet操作易出问题
   新建工作表后直接用wbk_main.ActiveSheet操作，Excel的活动表可能在后台切换，导致后续引用的工作表不是你刚新建的那个，进而引发复制操作失败。

修正后的代码 #

Sub GetSheets(wbkName)
    Dim ws As Worksheet
    Dim wbk As Workbook
    Dim wb_Name As String
    Dim newWs As Worksheet ' 保存新建的工作表对象，避免依赖ActiveSheet

    Set wbk = Application.Workbooks(wbkName)
           
    For Each ws In wbk.Worksheets
        wb_Name = ws.Name
        If InStr(wb_Name, "15") Then
            ' 新建工作表并直接保存对象引用
            Set newWs = wbk_main.Sheets.Add(After:=wbk_main.Sheets(wbk_main.Sheets.Count))
            newWs.Name = wb_Name
            
            ' 写入表头，用With简化代码
            With newWs
                .Range("A1") = "Reviewer"
                .Range("B1") = "Criterion"
                .Range("C1") = "Type"
                .Range("D1") = "Level"
                .Range("E1") = "Comment"
                .Range("A1:E1").Font.Bold = True
            End With
            
            ' 明确限定源范围的工作表归属，彻底避免活动表干扰
            ws.Range(ws.Range("A39"), ws.Range("H39").End(xlDown)).Copy newWs.Range("A2")
            
            MsgBox "Done"
        End If
    Next ws
End Sub

额外优化建议 #

• 可以加入错误捕获，方便排查潜在问题：

  Sub GetSheets(wbkName)
      On Error GoTo ErrorHandler ' 启用错误捕获
      ' ... 上述修正后的代码 ...
      Exit Sub
  ErrorHandler:
      MsgBox "错误代码：" & Err.Number & vbCrLf & "错误信息：" & Err.Description
  End Sub
  

• 原代码中的变量i未实际使用，可直接删除。

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