3

假设我有一个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后来被打开了。我不想这样做。

我该如何解决这些问题？

4

4 回答 4

3

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

几个简单的步骤：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
于 2013-06-22T19:16:38.140 回答
1

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

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
于 2015-05-02T21:25:53.233 回答
0

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

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它实际上就被打开了（虽然没有命名为 til ）：SaveAs

 Set Output = Workbooks.Add

保存后关闭即可：

 Output.Close
于 2013-06-22T14:50:59.367 回答
0

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

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
于 2013-06-22T16:44:34.363 回答