Excel VBA：将多个工作表复制到新工作簿中

当我运行这个子文件时，我有一个'Object Required'的错误信息。 我有一个版本用于复制每个特定的工作表，这工作正常，但是这个子工作室是所有工作表内的工作，即复制每个人的WholePrintArea并粘贴到新的工作表中的新工作表。 谢谢…

Sub NewWBandPasteSpecialALLSheets() MyBook = ActiveWorkbook.Name ' Get name of this book Workbooks.Add ' Open a new workbook NewBook = ActiveWorkbook.Name ' Save name of new book Workbooks(MyBook).Activate ' Back to original book Dim SH As Worksheet For Each SH In MyBook.Worksheets SH.Range("WholePrintArea").Copy Workbooks(NewBook).Activate With SH.Range("A1") .PasteSpecial (xlPasteColumnWidths) .PasteSpecial (xlFormats) .PasteSpecial (xlValues) End With Next End Sub 

Answer 1

尝试做这样的事情（问题是你试图使用MyBook.Worksheets ，但MyBook不是一个Workbook对象，但string ，包含工作簿名称。我已经添加新variablesSet WB = ActiveWorkbook ，所以你可以使用WB.Worksheets而不是MyBook.Worksheets ）：

 Sub NewWBandPasteSpecialALLSheets() MyBook = ActiveWorkbook.Name ' Get name of this book Workbooks.Add ' Open a new workbook NewBook = ActiveWorkbook.Name ' Save name of new book Workbooks(MyBook).Activate ' Back to original book Set WB = ActiveWorkbook Dim SH As Worksheet For Each SH In WB.Worksheets SH.Range("WholePrintArea").Copy Workbooks(NewBook).Activate With SH.Range("A1") .PasteSpecial (xlPasteColumnWidths) .PasteSpecial (xlFormats) .PasteSpecial (xlValues) End With Next End Sub 

但是，你的代码不能做你想做的事情：它不会把某些东西复制到新的WB中。 所以，下面的代码为你做：

 Sub NewWBandPasteSpecialALLSheets() Dim wb As Workbook Dim wbNew As Workbook Dim sh As Worksheet Dim shNew As Worksheet Set wb = ThisWorkbook Workbooks.Add ' Open a new workbook Set wbNew = ActiveWorkbook On Error Resume Next For Each sh In wb.Worksheets sh.Range("WholePrintArea").Copy 'add new sheet into new workbook with the same name With wbNew.Worksheets Set shNew = Nothing Set shNew = .Item(sh.Name) If shNew Is Nothing Then .Add After:=.Item(.Count) .Item(.Count).Name = sh.Name Set shNew = .Item(.Count) End If End With With shNew.Range("A1") .PasteSpecial (xlPasteColumnWidths) .PasteSpecial (xlFormats) .PasteSpecial (xlValues) End With Next End Sub 

Answer 2

这工作对我来说（我添加了“如果表可见”，因为在我的情况下，我想跳过隐藏的表）

  Sub Create_new_file() Application.DisplayAlerts = False Dim wb As Workbook Dim wbNew As Workbook Dim sh As Worksheet Dim shNew As Worksheet Dim pname, parea As String Set wb = ThisWorkbook Workbooks.Add Set wbNew = ActiveWorkbook For Each sh In wb.Worksheets pname = sh.Name If sh.Visible = True Then sh.Copy After:=wbNew.Sheets(Sheets.Count) wbNew.Sheets(Sheets.Count).Cells.ClearContents wbNew.Sheets(Sheets.Count).Cells.ClearFormats wb.Sheets(sh.Name).Activate Range(sh.PageSetup.PrintArea).Select Selection.Copy wbNew.Sheets(pname).Activate Range("A1").Select With Selection .PasteSpecial (xlValues) .PasteSpecial (xlFormats) .PasteSpecial (xlPasteColumnWidths) End With ActiveSheet.Name = pname End If Next wbNew.Sheets("Hoja1").Delete Application.DisplayAlerts = True End Sub 

Answer 3

重新思考你的方法。 你为什么只复制表格的一部分？ 您指的是不存在的命名范围“WholePrintArea”。 你也不应该使用激活，select，复制或粘贴你的脚本。 这使得“脚本”容易受到用户操作和其他同时执行的影响。 在最糟糕的情况下，数据最终会落在坏人的手中。

Answer 4

“从多个工作表复制数据到新的工作簿 – Yogesh Tanguturu

 Sub CopySheets() Dim LastRow As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False 'Creating the new workbook Set DestinationBook = Workbooks.Add ActiveWorkbook.SaveAs "C:\temp\BSExcel.xls" 'Adding a headline to the sheet in the new workbook DestinationBook.Sheets("Sheet1").Range("A1").Select ActiveCell.FormulaR1C1 = "Summary" ActiveCell.Font.Bold = True 'Copying data from only used cells of Sheet1 ThisWorkbook.Sheets("Sheet1").Activate LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row Range("A1:C" & LastRow).Select Selection.Copy 'Pasting the data of Sheet1 into the new workbook DestinationBook.Sheets("Sheet1").Activate LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row Range("A" & LastRow + 2).Select Selection.PasteSpecial 'Copying data from only used cells of Sheet2 ThisWorkbook.Sheets("Sheet2").Activate LastRow = ActiveSheet.Cells(Rows.Count, "C").End(xlUp).Row Range("A1:C" & LastRow).Select Selection.Copy 'Pasting the data of Sheet2 into the new workbook DestinationBook.Sheets("Sheet1").Activate LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row Range("A" & LastRow + 2).Select Selection.PasteSpecial DestinationBook.Worksheets("Sheet1").Columns("A:C").AutoFit DestinationBook.Save DestinationBook.Close Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True End Sub