使用 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

Answer 2

下面的代码采用与前面代码相反的方法。它将整个工作簿复制到一个新名称，然后对其进行修改。您可以列出要保留的工作表。其中的公式将转换为它们的值。未列出的工作表将被删除。

Sub SaveValuesOnly()
    ' 154

    ' list the sheets you want to keep by their tab names
    Const SheetsToKeep  As String = "Sheet1,Sheet3"
    
    Dim sFileName       As String
    Dim sPath           As String
    Dim Wb              As Workbook             ' the new workbook
    Dim Ws              As Worksheet            ' looping object: worksheet
    Dim Keep()          As String               ' array of SheetsToKeep
    Dim i               As Long                 ' loop counter: Keep index
    
    sPath = Environ("UserProfile") & "\Desktop\"
    sFileName = "OVERALL RECAP"
    Keep = Split(SheetsToKeep, ",")
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    ' create a copy of the ActiveWorkbook under a new name
    ActiveWorkbook.SaveCopyAs sPath & sFileName & ".xlsm"
    Set Wb = Workbooks.Open(sPath & sFileName & ".xlsm")
    
    For Each Ws In Wb.Worksheets
        ' check if the sheet is to be kept
        For i = UBound(Keep) To 0 Step -1
            If StrComp(Ws.Name, Trim(Keep(i)), vbTextCompare) = 0 _
               Then Exit For
        Next i
        If i = True Then                        ' True = -1
            Ws.Delete
        Else
            ' keep the sheet
            With Ws.UsedRange
                .Copy
                .PasteSpecial xlPasteValuesAndNumberFormats
                ' you can repeat PasteSpecial here to copy more detail
            End With
        End If
    Next Ws

    ' change the file format to xlsx (deleting copy of this code in it)
    Wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
    Kill sPath & sFileName & ".xlsm"
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

您需要注意几点。一，ActiveWorkbook 将被复制。这被假定为ThisWorkbook（包含代码的那个），但它可能是任何其他的。第二，在sPath 指定的位置已经存在的目标名称的任何工作簿都将被覆盖而不会发出警告。第三，在代码运行时关闭警报。如果它发生崩溃，它们将保持关闭状态，直到您重新启动 Excel 或在“立即”窗口中输入 Application.DisplayAlerts = True [Enter]。

最后但并非最不重要的一点是，工作表按其索引号的顺序（从左到右）进行处理。如果保留工作表中的公式引用了工作表中被删除的数据，则序列很重要。您可能必须运行两个循环，而不是我的代码中的一个。使用一个循环替换公式，另一个循环删除。