Копирование значений только в новую книгу из нескольких листов

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), как только вы называете это:

Set Output = Workbooks.Add 

Просто закрыть его после сохранения:

Output.Close 

Answer 3

Что-то, как это будет работать циклически перебирать и копировать все листы после добавления книги - она ​​основывается на ответе мр.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