vba 仅将值从多个工作表复制到新工作簿

Copy values only to new workbook from multiple worksheets

提问by alex

Suppose I have a workbook1.xlsmwith multiple worksheets and full of various formulas. I want to create a new workbook2.xlsxwhich would look exactlythe same as workbook1but in all the cells would be values instead of formulas.

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

I have this macro to copy one sheet from 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

but the problem is it copies only one worksheet and does not name it like it was in worksheet1. I cannot figure it out.

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

Yet another problem is that worksheet2is being opened afterwards. I do not want to do this.

另一个问题是worksheet2后来被打开。我不想这样做。

How can I solve these problems?

我该如何解决这些问题？

回答by Kazimierz Jawor

I would do that as simply as possibly, without creating new workbook and copying sheets to it.

我会尽可能简单地做到这一点，而不会创建新的工作簿并将工作表复制到其中。

Few simple steps: 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.

几个简单的步骤： 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.

The code will be simple and looks as follows:

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

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

回答by Dustin Nicholas

This should allow you to keep all the formatting, column widths, and only the values.

这应该允许您保留所有格式、列宽和仅值。

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

回答by mr.Reband

Something like this would work to cycle through and copy all sheets after adding the workbook:

添加工作簿后，这样的事情可以循环并复制所有工作表：

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

Note that this doesn't handle removing default sheets that automatically get created when the workbook gets created.

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

Also, worksheet2is actually being opened (though not named til SaveAs) as soon as you call this:

此外，一旦您调用它，worksheet2实际上正在打开（尽管未命名为 til SaveAs）：

 Set Output = Workbooks.Add

Just close it after saving:

保存后关闭即可：

 Output.Close

回答by Floris

Something like this would work to cycle through and copy all sheets after adding the workbook - it builds on mr.Reband's answer, but with a few bells and whistles. Among other things it will work if this is in a third workbook (or an add-in etc), it deletes the default sheet or sheets that were created, it ensures the order of the sheets is the same as the original, etc:

添加工作簿后，这样的事情可以循环并复制所有工作表 - 它建立在雷班先生的回答上，但有一些花里胡哨的东西。如果这是在第三个工作簿（或加载项等）中，它会起作用，它会删除创建的默认工作表或工作表，确保工作表的顺序与原始工作表相同，等等：

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