將值僅複製到多個工作表中的新工作簿

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

像這樣的工作，通過循環和增加工作簿畢竟張複製：

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命名），只要你把這個：

Output.Close 

Answer 3

像這樣的工作：

Set Output = Workbooks.Add 

保存之後就關閉在添加工作簿之後循環並複製所有工作表 - 它以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 

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