复制工作表至已关闭工作簿的VBA代码异常问题求助

问题根源 #

• 打开目标工作簿后，ActiveSheet自动切换为目标工作簿的首个工作表，导致ActiveSheet.Move操作移动的是目标工作簿的表，而非需要复制的源工作表
• 代码依赖Select/Selection操作，极易因上下文切换出错；同时字符串常量误用单引号（VBA规定字符串需用双引号包裹）
• 直接修改源工作表的数据（粘贴为值）会破坏原始文件，逻辑错误

修正后的VBA代码 #

Sub CopySheetToClosedWB()
    Dim SheetName As String
    Dim targetWBPath As String
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim copiedWS As Worksheet
    Dim targetWB As Workbook
    
    ' 获取目标工作表名称
    SheetName = InputBox("输入要复制的工作表名称:", "复制工作表")
    If SheetName = "" Then Exit Sub ' 用户取消输入则终止
    
    Set sourceWB = ThisWorkbook ' 指向当前运行代码的工作簿
    On Error Resume Next
    Set sourceWS = sourceWB.Sheets(SheetName)
    On Error GoTo 0
    
    ' 校验工作表是否存在
    If sourceWS Is Nothing Then
        MsgBox "指定的工作表不存在!", vbExclamation
        Exit Sub
    End If
    
    targetWBPath = "D:\Users\User\Desktop\REPORTS\8Z-XF010CS\CTIC\October Filter PM\Current Transformer Inspection Checklist.xlsx"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False ' 关闭操作提示
    
    ' 打开目标工作簿
    Set targetWB = Workbooks.Open(targetWBPath)
    
    ' 复制源工作表到目标工作簿的末尾
    sourceWS.Copy After:=targetWB.Sheets(targetWB.Sheets.Count)
    Set copiedWS = targetWB.Sheets(targetWB.Sheets.Count)
    
    ' 调整格式并转换为数值
    copiedWS.Cells.EntireColumn.AutoFit
    copiedWS.Cells.EntireRow.AutoFit
    copiedWS.UsedRange.Value = copiedWS.UsedRange.Value ' 直接赋值替代复制粘贴
    
    ' 重命名复制后的工作表
    copiedWS.Name = SheetName
    
    ' 保存并关闭目标工作簿
    targetWB.Close SaveChanges:=True
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "操作完成!"
End Sub

核心优化点 #

• 全程使用对象引用（如sourceWS、copiedWS），彻底避免ActiveSheet/Select带来的上下文错误
• 先复制工作表副本到目标工作簿，再处理格式和数值，不改动源文件数据
• 增加输入验证、工作表存在性检查，提升代码稳定性
• 关闭冗余提示框，优化运行流畅度

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