excel - 使用 VBA 宏复制多张纸

Question

我是 VBA 的初学者，我需要执行以下操作。从工作簿开始，我应该创建另一个没有公式和宏代码的工作簿。
我找到了一些解决方案，并在此基础上对自己的代码进行了建模:

    Sub SaveValuesOnly()
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim sFileName As String, sPath As String


    sPath = "C:\Users\"
    sFileName = "OVERALL RECAP"
    Set wsCopy = ThisWorkbook.Worksheets("INCIDENTS")
    Set wb = Workbooks.Add
    Set wsPaste = wb.Sheets(1)
    
    
    wsCopy.Cells.copy
    wsPaste.Cells.PasteSpecial xlPasteValues
    wsPaste.Cells.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
      
    
    wsPaste.Name = "Expenses" 'Change if needed
    wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
    
End Sub

我需要复制多张纸并尝试使用官方文档，例如:

Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy
  With ActiveWorkbook
 .SaveAs Filename:=Environ("TEMP") & "\New3.xlsx", FileFormat:=xlOpenXMLWorkbook 
 .Close SaveChanges:=False 
 End With 

但是我没有设法在上面的代码中实现这一点，有什么建议吗？谢谢。

Answer 1

将工作表复制到新工作簿
流量
基本上，该程序将:

创建 ThisWorkbook 的副本(包含此代码的工作簿)在目标文件夹中，

打开副本并继续使用它，

将值复制到(从中删除公式)指定的工作表，

删除未指定的工作表，

重命名指定的工作表，

将副本保存到 .xlsx 中的新工作簿中格式，

删除副本。

备注

如果同名的工作簿(例如 OVERALL RECAP )已经打开，它将崩溃 Excel .

确定工作表名称时要小心，因为如果您尝试使用已经存在的名称重命名工作表，则会发生错误。

代码

Option Explicit

Sub copyWorksheets()
    
    Const dPath As String = "C:\Users"
    Const dFileName As String = "OVERALL RECAP"
    Const CopyList As String = "INCIDENTS,Sheet2,Sheet3"
    Const PasteList As String = "Expenses,Sheet2,Sheet4"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim CopyNames() As String: CopyNames = Split(CopyList, ",")
    Dim PasteNames() As String: PasteNames = Split(PasteList, ",")
    Dim nUpper As Long: nUpper = UBound(CopyNames)
    Dim tFilePath As String: tFilePath = dPath & "\" & "t_" & wb.Name
    
    Application.ScreenUpdating = False
    
    ' Save a copy.
    wb.SaveCopyAs tFilePath
    
    ' Work with the copy.
    With Workbooks.Open(tFilePath)
        ' Copy values (remove formulas).
        Dim n As Long
        For n = 0 To nUpper
            With .Worksheets(CopyNames(n)).UsedRange
                .Value = .Value
            End With
        Next n
        ' Delete other sheets.
        Dim dCount As Long: dCount = .Sheets.Count - nUpper - 1
        If dCount > 0 Then
            Dim DeleteNames() As String: ReDim DeleteNames(1 To dCount)
            Dim sh As Object ' There maybe e.g. charts.
            n = 0
            For Each sh In .Sheets
                If IsError(Application.Match(sh.Name, CopyNames, 0)) Then
                    n = n + 1
                    DeleteNames(n) = sh.Name
                End If
            Next sh
            Application.DisplayAlerts = False
            .Sheets(DeleteNames).Delete
            Application.DisplayAlerts = True
        End If
        ' Rename worksheets.
        For n = 0 To nUpper
            If CopyNames(n) <> PasteNames(n) Then
                .Worksheets(CopyNames(n)).Name = PasteNames(n)
            End If
        Next n
        ' Save workbook.
        .Worksheets(1).Activate
        Application.DisplayAlerts = False
        .SaveAs _
            Filename:=dPath & "\" & dFileName, _
            FileFormat:=xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        '.Close SaveChanges:=False ' Close the new workbook.
    End With
  
    ' Delete the copy.
    Kill tFilePath
    
    Application.ScreenUpdating = True
    
    MsgBox "Workbook created.", vbInformation, "Success"
    
    'wb.Close SaveChanges:=False ' Close ThisWorkbook.

End Sub