将多个工作表复制到新工作簿，同时仅保留值和数据透视表

如何解决将多个工作表复制到新工作簿，同时仅保留值和数据透视表

我正在尝试创建一个宏，该宏将多个工作表的值（除了第一个）从活动工作簿复制到新工作簿中，我已将其路径放在 sheet1 的单元格 F21 中。

下面的代码使我能够为 sheet2 执行此操作。但我似乎无法找到如何调整它以使其适用于第 2、3、4、5、6、7、8 和 9 页。

另一个需要注意的有趣的事情是 sheet8 包含数据透视表，将其复制到另一个工作表时似乎是一个问题。

你知道我怎么做吗？ （顺便说一句，如果你有想法怎么做，但是新文件中包含了sheet1，那问题不大）

非常感谢。

Sub export()

Dim SourceBook As Workbook,DestBook As Workbook,SourceSheet As Worksheet,DestSheet As Worksheet

Dim SavePath As String,i As Integer

Application.ScreenUpdating = False

Set SourceBook = ThisWorkbook

SavePath = Sheets("Sheet1").Range("F21").Text
Set SourceSheet = SourceBook.Sheets("Sheet2")

Set DestBook = Workbooks.Add
Set DestSheet = DestBook.Worksheets.Add

Application.DisplayAlerts = False
For i = DestBook.Worksheets.Count To 2 Step -1
    DestBook.Worksheets(i).Delete
Next i
Application.DisplayAlerts = True

SourceSheet.Cells.Copy
With DestSheet.Range("A1")
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats 'Delete if you don't want formats copied
End With

DestSheet.Name = SourceSheet.Name
DestBook.Activate
With ActiveWindow
    .DisplayGridlines = False
    .DisplayWorkbookTabs = False
End With
SourceBook.Activate

Application.DisplayAlerts = False 'Delete if you want overwrite warning
DestBook.SaveAs Filename:=SavePath
Application.DisplayAlerts = True 'Delete if you delete other line

SavePath = DestBook.FullName
DestBook.Close 'Delete if you want to leave copy open
MsgBox ("A copy has been saved to " & SavePath)

End Sub

解决方法

我强烈建议您研究以下主题。我提供了几个链接以帮助您入门。

• 将参数传递给过程 (https://www.homeandlearn.org/passing_values_to_a_sub.html)
• 参数和参数 (https://stackoverflow.com/questions/156767/whats-the-difference-between-an-argument-and-a-parameter#:~:text=Generally%20speaking%2C%20the%20terms%20parameter,function%20when%20it%20is%20called.)
• 模块化编程 (https://en.wikipedia.org/wiki/Modular_programming)

下面的代码传递参数并循环遍历所有工作表。此设置允许您通过更改 iSheetStart 过程中 iSheetEnd 和 DoExport 参数的值来复制任意数量的（连续）工作表。由于逻辑已被抽象化并拆分为更模块化的形式，因此它足够通用，您可以一遍又一遍地使用相同的代码，而无需每次都重新编写代码。其中一些逻辑也可以进一步拆分为更多过程。

您还可以通过更改对过程参数具有 "Delete if..." 注释的所有情况来进一步抽象代码。您还可以制作 SavePath、SourceBook、Destbook 等参数。

我还鼓励您查看 Worksheets.Copy 方法 (https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.copy)。这可能比您目前正在做的更快，尽管我不相信有排除格式的选项。

您应该运行的过程是DoExport。所有其他过程都将被它调用。

Option Explicit
    
    
Sub DoExport()

    Export iStartSheet:=2,iEndSheet:=9
    
End Sub


Sub Export(iStartSheet As Integer,iEndSheet As Integer)

    Dim SourceBook      As Workbook:    Set SourceBook = ThisWorkbook
    Dim SavePath        As String:      SavePath = SourceBook.Sheets("Sheet1").Range("F21").Text
    Dim DestBook        As Workbook:    Set DestBook = Workbooks.Add
    Dim iSheetNum       As Integer
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    For iSheetNum = iStartSheet To iEndSheet
        CopySheet SourceBook,DestBook,iSheetNum
    Next iSheetNum
    
    DestBook.Activate
    With ActiveWindow
        .DisplayGridlines = False
        .DisplayWorkbookTabs = False
    End With
    
    DestBook.SaveAs Filename:=SavePath
    With Application
        .DisplayAlerts = False 'Delete if you want overwrite warning
        .DisplayAlerts = True 'Delete if you delete other line
    End With
    
    DestBook.Close 'Delete if you want to leave copy open
    MsgBox ("A copy has been saved to " & SavePath)

End Sub


Sub CopySheet(SourceBook As Workbook,ByRef DestBook As Workbook,iSheetNum As Integer)

    Dim SourceSheet     As Worksheet
    Dim DestSheet       As Worksheet
    
    With DestBook.Sheets
        Set DestSheet = IIf(.Count < iSheetNum,_
                            .Add(After:=DestBook.Sheets(.Count)),_
                            DestBook.Sheets(iSheetNum))
    End With
    
    Set SourceSheet = SourceBook.Sheets(iSheetNum)
    SourceSheet.Cells.Copy
    With DestSheet
        With .Range("A1")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats 'Delete if you don't want formats copied
        End With
        .Name = SourceSheet.Name
    End With

End Sub