如何让Excel宏保存工作簿副本后仍保留原工作簿状态？

现有Excel VBA宏可接收输入、拉取对应数据并为每个输入创建独立工作表，随后将工作簿另存为新文件。但当前使用SaveAs方法会导致正在操作的文件变为新保存的文件，需求改为：保存当前状态的工作簿副本，随后删除生成的工作表以重置原工作簿，方便下次使用报表生成器，询问该方案是否可行。

参考代码 #

Sub Generate()
    ' Generates reports for each order
    Dim WB As Workbook
    Set WB = ActiveWorkbook
    
    Dim ORD As Worksheet, LOT As Worksheet
    Set ORD = WB.Sheets("Orders")
    Set LOT = WB.Sheets("Order To Lot")
    
    Dim StartRow As Integer, RowCount As Integer, OrderCol As String, CurrOrder As String, ReportName As String
    StartRow = 3
    RowCount = ORD.Range("H1").Value
    OrderCol = "I"
    ReportName = ORD.Range("H2").Value
    
    For i = StartRow To StartRow + RowCount - 1
        Dim CurrLoc As String, CurrCell As Range
        CurrLoc = OrderCol & i
        Set CurrCell = ORD.Range(CurrLoc)
        
        If IsEmpty(CurrCell) Then
            Exit For
        Else
            CurrOrder = CurrCell.Value
            CreateSheet (CurrOrder)
            GetLotList (CurrOrder)
            
            Dim CO As Worksheet
            Set CO = ActiveWorkbook.Sheets(CurrOrder)
            
            CO.Range("A1").Value = "Order #:"
            CO.Range("B1").Value = "" & CurrOrder
            CO.Range("A" & 2 & ":L" & 2).Value = ORD.Range("A" & i & ":L" & i).Value
            
            Dim LotValues As Range, Dest As Range
            Set LotValues = Sheets("Order To Lot").Range("Table_Query_from_as400[#All]")
            LotValues.Copy
            Set Dest = CO.Range("A3")
            Dest.PasteSpecial xlPasteValues
            
            CO.Cells.EntireColumn.AutoFit
        End If
    Next i

    If Not IsEmpty("A3") Then
        WB.SaveAs GetFolder & "\" & ReportName & ".xlsm"
        ORD.Visible = xlSheetVeryHidden
        LOT.Visible = xlSheetVeryHidden
    End If
End Sub

Function CreateSheet(SheetName As String)
    Sheets.Add After:=ActiveWorkbook.Sheets("Order To Lot"), Type:=xlWorksheet
    ActiveWorkbook.Sheets("Order To Lot").Next.Name = SheetName
End Function

Function Refresh()
    ' Refreshes Query
    ThisWorkbook.Worksheets("Order To Lot").ListObjects("Table_Query_from_as400").QueryTable.Refresh BackgroundQuery:=False
End Function

Function GetLotList(OrderNo As String)
    ActiveWorkbook.Sheets("Order To Lot").Range("B1").Value = "" & OrderNo
    Refresh
End Function

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

解决方案：可行，修改代码如下 #

关键改动说明 #

1. 替换SaveAs为SaveCopyAs：该方法仅保存工作簿副本，不会改变当前活动工作簿的指向，原工作簿保持打开状态。
2. 添加生成工作表的删除逻辑：遍历并删除除"Orders"和"Order To Lot"之外的所有工作表，重置原工作簿。
3. 修正判断条件：原代码If Not IsEmpty("A3")逻辑错误，改为判断是否存在生成的工作表。
4. 恢复原始工作表可见性：避免下次使用时找不到操作界面。

修改后的完整代码 #

Sub Generate()
    ' Generates reports for each order
    Dim WB As Workbook
    Set WB = ActiveWorkbook
    
    Dim ORD As Worksheet, LOT As Worksheet
    Set ORD = WB.Sheets("Orders")
    Set LOT = WB.Sheets("Order To Lot")
    
    Dim StartRow As Integer, RowCount As Integer, OrderCol As String, CurrOrder As String, ReportName As String
    Dim generatedSheets As New Collection ' 存储生成的工作表名称，方便后续删除
    StartRow = 3
    RowCount = ORD.Range("H1").Value
    OrderCol = "I"
    ReportName = ORD.Range("H2").Value
    
    For i = StartRow To StartRow + RowCount - 1
        Dim CurrLoc As String, CurrCell As Range
        CurrLoc = OrderCol & i
        Set CurrCell = ORD.Range(CurrLoc)
        
        If IsEmpty(CurrCell) Then
            Exit For
        Else
            CurrOrder = CurrCell.Value
            CreateSheet CurrOrder
            generatedSheets.Add CurrOrder ' 记录生成的工作表名称
            GetLotList CurrOrder
            
            Dim CO As Worksheet
            Set CO = WB.Sheets(CurrOrder) ' 改用指定工作簿，避免ActiveWorkbook切换问题
            
            CO.Range("A1").Value = "Order #:"
            CO.Range("B1").Value = CurrOrder
            CO.Range("A2:L2").Value = ORD.Range("A" & i & ":L" & i).Value
            
            Dim LotValues As Range, Dest As Range
            Set LotValues = LOT.Range("Table_Query_from_as400[#All]")
            LotValues.Copy
            Set Dest = CO.Range("A3")
            Dest.PasteSpecial xlPasteValues
            
            CO.Cells.EntireColumn.AutoFit
        End If
    Next i

    ' 判断是否生成了工作表
    If generatedSheets.Count > 0 Then
        Dim savePath As String
        savePath = GetFolder & "\" & ReportName & ".xlsm"
        If savePath <> "\" & ReportName & ".xlsm" Then ' 确保用户选择了文件夹
            ' 保存工作簿副本，不改变当前工作簿
            WB.SaveCopyAs savePath
            
            ' 删除生成的工作表
            Application.DisplayAlerts = False ' 关闭删除确认提示
            Dim sheetName As Variant
            For Each sheetName In generatedSheets
                WB.Sheets(sheetName).Delete
            Next sheetName
            Application.DisplayAlerts = True
            
            ' 恢复原始工作表的可见性，方便下次操作
            ORD.Visible = xlSheetVisible
            LOT.Visible = xlSheetVisible
            
            ' 重置查询参数
            LOT.Range("B1").ClearContents
        End If
    End If
End Sub

Function CreateSheet(SheetName As String)
    Dim newSheet As Worksheet
    Set newSheet = Sheets.Add(After:=ThisWorkbook.Sheets("Order To Lot"), Type:=xlWorksheet)
    newSheet.Name = SheetName
End Function

Function Refresh()
    ' Refreshes Query
    ThisWorkbook.Worksheets("Order To Lot").ListObjects("Table_Query_from_as400").QueryTable.Refresh BackgroundQuery:=False
End Function

Function GetLotList(OrderNo As String)
    ThisWorkbook.Sheets("Order To Lot").Range("B1").Value = OrderNo
    Refresh
End Function

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

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