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

Question

假设我有一个

workbook1.xlsm

，其中有多个工作表并且充满了各种公式。我想创建一个新的

workbook2.xlsx

，它看起来与 workbook1 完全一样，但在所有单元格中都是值而不是公式。我有这个宏可以从

workbook1

复制一张纸：

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

几个简单的步骤：

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

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

Answer 3

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

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

此外，一旦您调用此命令，

worksheet2

实际上就会被打开（尽管没有命名为

SaveAs

）： Set Output = Workbooks.Add

保存后关闭即可：

Output.Close

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:=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 5