仅将值复制到多个工作表中的新工作簿

假设我有一个workbook1.xlsm与多个工作表和充满各种公式。 我想创build一个新的workbook2.xlsx ，它看起来和 workbook2.xlsx 完全一样，但是在所有单元格中都是值而不是公式。

我有这个macros从workbook1 1复制一张：

 Sub nowe() Dim Output As Workbook Dim FileName As String Set Output = Workbooks.Add Application.DisplayAlerts = False ThisWorkbook.Worksheets("Przestoje").Cells.Copy Selection.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=True, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx" Output.SaveAs FileName End Sub 

但问题是它只复制一个工作表，并没有像它在worksheet1 。 我想不明白。

还有一个问题是worksheet2正在被打开。 我不想这样做。

我怎样才能解决这些问题？

Answer 1

我会尽可能地做到这一点，而不需要创build新的工作簿并将其复制到它。

几个简单的步骤： taking into consideration thisworkbook >> for each worksheet within thisworkbook >> copy+paste values of used range within worksheet >> save as new workbook as xlsx type >> open back base workbook >> and finally close one we created.

代码将很简单，如下所示：

 Sub nowe_poprawione() Dim Output As Workbook Dim Current As String Dim FileName As String Set Output = ThisWorkbook Current = ThisWorkbook.FullName Application.DisplayAlerts = False Dim SH As Worksheet For Each SH In Output.Worksheets SH.UsedRange.Copy SH.UsedRange.PasteSpecial xlPasteValues, _ Operation:=xlNone, SkipBlanks:=True, Transpose:=False Next FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx" Output.SaveAs FileName, XlFileFormat.xlOpenXMLWorkbook Workbooks.Open Current Output.Close Application.DisplayAlerts = True End Sub 

Answer 2

像这样的东西将工作循环，并添加工作簿后复制所有工作表：

 dim i as integer For i = 1 To ThisWorkbook.Worksheets.Count ThisWorkbook.Worksheets(i).Activate ThisWorkbook.Worksheets(i).Select Cells.Copy Output.Activate Dim newSheet As Worksheet Set newSheet = Output.Worksheets.Add() newSheet.Name = ThisWorkbook.Worksheets(i).Name newSheet.Select Cells.Select Selection.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=True, Transpose:=False Next 

请注意，这不处理删除工作簿创build时自动创build的默认工作表。

另外，只要调用此方法， worksheet2实际上正在打开（尽pipe不会命名为SaveAs ）：

  Set Output = Workbooks.Add 

保存后closures它：

  Output.Close 

Answer 3

类似这样的工作将循环和复制所有工作表后添加工作簿 – 它build立在先生的答案，但有一些花里胡哨。 除此之外，如果这是在第三个工作簿（或加载项等）中，它将工作，删除所创build的默认工作表或工作表，它确保工作表的顺序与原始工作表相同：

 Option Explicit Sub copyAll() Dim Output As Workbook, Source As Workbook Dim sh As Worksheet Dim FileName As String Dim firstCell Application.ScreenUpdating = False Set Source = ActiveWorkbook Set Output = Workbooks.Add Application.DisplayAlerts = False Dim i As Integer For Each sh In Source.Worksheets Dim newSheet As Worksheet ' select all used cells in the source sheet: sh.Activate sh.UsedRange.Select Application.CutCopyMode = False Selection.Copy ' create new destination sheet: Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count)) newSheet.Name = sh.Name ' make sure the destination sheet is selected with the right cell: newSheet.Activate firstCell = sh.UsedRange.Cells(1, 1).Address newSheet.Range(firstCell).Select ' paste the values: Range(firstCell).PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=True, Transpose:=False Next ' delete the sheets that were originally there While Output.Sheets.Count > Source.Worksheets.Count Output.Sheets(1).Delete Wend FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx" Output.SaveAs FileName Output.Close Application.ScreenUpdating = True End Sub 

Answer 4

这应该允许您保留所有的格式，列宽和只有值。

 Option Explicit Sub copyAll() Dim Output As Workbook, Source As Workbook Dim sh As Worksheet Dim FileName As String Dim firstCell Application.ScreenUpdating = False Set Source = ActiveWorkbook Set Output = Workbooks.Add Application.DisplayAlerts = False Dim i As Integer For Each sh In Source.Worksheets Dim newSheet As Worksheet ' select all used cells in the source sheet: sh.Activate sh.UsedRange.Select Application.CutCopyMode = False Selection.Copy ' create new destination sheet: Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count)) newSheet.Name = sh.Name ' make sure the destination sheet is selected with the right cell: newSheet.Activate firstCell = sh.UsedRange.Cells(1, 1).Address newSheet.Range(firstCell).Select ' paste the values: Range(firstCell).PasteSpecial Paste:=xlPasteColumnWidths Range(firstCell).PasteSpecial Paste:=xlPasteFormats Range(firstCell).PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=True, Transpose:=False Next ' delete the sheets that were originally there While Output.Sheets.Count > Source.Worksheets.Count Output.Sheets(1).Delete Wend FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx" Output.SaveAs FileName Output.Close Application.ScreenUpdating = True End Sub