I am attempting to copy/paste values from one open workbook to another.
Neither of the workbooks will have static names, so there will be no name consistency.
Both of my workbooks will be open and will be the only open files.
Can someone help me fix this code to work when I don't know the file names?
Range("M7:R19").Select
Selection.Copy
Windows("new template.xlsm").Activate
Range("M7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("old template.xlsm").Activate
Range("S7:AT16").Select
Application.CutCopyMode = False
Selection.Copy
Windows("new template.xlsm").Activate
Range("U7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Alternative method using Like operator to test for source/destination workbooks. Also provides a way to define source/destination ranges that can be looped through for ease of debugging and updating later. Code heavily commented for clarity.
Sub tgr()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
'Check if exactly 2 workbooks are currently open
If Application.Workbooks.Count <> 2 Then
MsgBox "ERROR - There are [" & Application.Workbooks.Count & "] workbooks open." & Chr(10) & _
"There must be two workbooks open:" & Chr(10) & _
"-The source workbook (old template)" & Chr(10) & _
"-The destination workbook"
Exit Sub
End If
For Each wb In Application.Workbooks
If wb.Name Like "*#.xls?" Then
'Workbook name ends in number(s), this is the source workbook that will be copied from
'You'll need to specify which sheet you're working with, this example code assumes the activesheet of that workbook
Set wsSource = wb.ActiveSheet
Else
'Workbook name does not end in number(s), this is the source workbook that will be pasted to
'You'll need to specify which sheet you're working with, this example code assumes the activesheet of that workbook
Set wsDest = wb.ActiveSheet
End If
Next wb
'Check if both a source and destination were assigned
If wsSource Is Nothing Then
MsgBox "ERROR - Unable to find valid source workbook to copy data from"
Exit Sub
ElseIf wsDest Is Nothing Then
MsgBox "ERROR - Unable to find valid destination workbook to paste data into"
Exit Sub
End If
'The first dimension is for how many times you need to define source and dest ranges, the second dimension should always be 1 to 2
Dim aFromTo(1 To 2, 1 To 2) As Range
'Add source copy ranges here: 'Add destination paste ranges here
Set aFromTo(1, 1) = wsSource.Range("M7:R19"): Set aFromTo(1, 2) = wsDest.Range("M7")
Set aFromTo(2, 1) = wsSource.Range("S7:AT16"): Set aFromTo(2, 2) = wsDest.Range("U7")
'Set aFromTo(3, 1) = wsSource.Range("M21:R33"): Set aFromTo(3, 2) = wsDest.Range("M21") 'Example of a third copy/paste range - Dim aFromTo(1 to 3, 1 to 2)
'Set aFromTo(4, 1) = wsSource.Range("S21:AT30"): Set aFromTo(4, 2) = wsDest.Range("U21") 'Example of a fourth copy/paste range - Dim aFromTo(1 to 4, 1 to 2)
'This will loop through the array of specified FromTo ranges and will ensure that only values are brought over
Dim i As Long
For i = LBound(aFromTo, 1) To UBound(aFromTo, 1)
aFromTo(i, 2).Resize(aFromTo(i, 1).Rows.Count, aFromTo(i, 1).Columns.Count).Value = aFromTo(i, 1).Value
Next i
End Sub
You'll have to create two Workbook variables, to distinquish between the one that you want to copy from and where you want to paste to. So something to get you started would be (since these are the only two workbooks open at run-time):
Sub Test()
Dim ws As Workbook, wbCopy As Workbook, wsPaste As Workbook
For Each wb In Application.Workbooks
If IsNumeric(Right(wb.Name, 1)) Then
Set wbCopy = wb
Else
Set wbPaste = wb
End If
Next wb
'Continue coding... Below is just an option:
wbPaste.Worksheets(1).Range("U7:AV16").Value = wbCopy.Worksheets(1).Range("S7:AT16").Value
'Same thing for other ranges....
End Sub
The second part of the code is for you to consider. I do not know which sheet you refer to on either workbook, nor do I know if you really need to copy/paste. In my example I went with the Worksheet with index 1 and I assumed a simple Value transfer may be what you actually want.
But these last two things are for you to consider.
Related
I am modifying my current code to be more user friendly. My original code had hard coded file paths. The new code below is passing the file paths from a "control" sub where they are designated by an input box. The issue I am having is that now, once in the private sub routine, the If statements are no longer working. The only difference is that the file path is being passed from another sub instead of being hardcoded into this sub. I'm not sure what I am missing. Any help would be great.
Private Sub copyGLbuildings(NewRecPath As String, GLsrcPath As String)
Dim fname1 As Variant
Dim fname2 As Variant
Dim wb1 As Workbook
Dim Wb0 As Workbook
fname1 = Dir(GLsrcPath & "*Buildings*")
fname2 = Dir(NewRecPath & "*Buildings Rec*")
If fname1 <> "" Then
Set wb1 = Workbooks.Open(GLsrcPath & fname1)
End If
If fname2 <> "" Then
Set Wb0 = Workbooks.Open(NewRecPath & fname2)
End If
Wb0.Sheets(1).Name = "Data"
Wb0.Sheets.Add.Name = "GL"
wb1.Worksheets(1).UsedRange.Copy
Wb0.Worksheets("GL").UsedRange.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Wb0.Worksheets("GL").UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Wb0.Worksheets("GL").UsedRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Wb0.Worksheets(1).Activate
ActiveWorkbook.Windows(1).DisplayGridlines = False
Call CleanFAGL
wb1.Close
Wb0.Close savechanges:=True
End Sub
The code looks fine to me. I would advise you put a break point right on the first If Statement and use View > Locals to check what the values of NewRecPath and GLsrcPath are being passed into the Sub Routine as.
Copy to Another Workbook
Using the Destination (written to) before the Source (read from) as the argument is quite unusual.
fname is better written like fName.
Neither of the fNames are ever going to be "", since you have previously added the patterns.
wb0 is a horrible idea, at least start numbering with 1 in the spirit of Excel and VBA. Note that my choice of variable names is also not quite good, but only you can improve it since you fully understand what it's all about.
If it's a worksheet then call it a worksheet (readability) or at least be consistent.
After adding a worksheet without arguments, it will 'land' before the selected (active) sheet, so if you only have one sheet in the workbook, it will be the first. If it isn't, why would you gamble with it, if you can settle this explicitly?
Have a think about the order of the PasteSpecial lines e.g. you adjusted the column widths before the data was copied.
Using sheet or worksheet indexes is prone to errors and confusion which in this case leads me to not knowing which worksheet should be 'deprived' of displaying grid lines.
The rest is covered in your comments.
Don't worry, we all were at this point at one time.
Carefully read the comments and modify the code appropriately.
Option Explicit
' Note that the arguments are switched due to the 'From To' logic.
Private Sub copyGLbuildings( _
ByVal SourcePath As String, _
ByVal DestinationPath As String)
' Validate
' Destination
Dim dwbName As String: dwbName = Dir(DestinationPath & "*Buildings Rec*")
If dwbName = "" Then Exit Sub
' Source
Dim swbName As String: swbName = Dir(SourcePath & "*Buildings*")
If swbName = "" Then Exit Sub
'Application.ScreenUpdating = False
' Destination
' Workbook
If Right(dwbName, 1) <> "\" Then
dwbName = dwbName & "\"
End If
Dim dwb As Workbook: Set dwb = Workbooks.Open(DestinationPath & dwbName)
' Worksheets
Dim dws1 As Worksheet: Set dws1 = dwb.Worksheets(1)
dws1.Name = "Data"
Dim dws2 As Worksheet
' Do it explicitly, even if there is previously only one worksheet.
Set dws2 = dwb.Worksheets.Add(After:=dws1) ' ??? maybe Before:=dws1
dws2.Name = "GL"
' Source
If Right(swbName, 1) <> "\" Then
swbName = swbName & "\"
End If
Dim swb As Workbook: Set swb = Workbooks.Open(SourcePath & swbName)
' Copy
swb.Worksheets(1).UsedRange.Copy
' Destination
' Paste
With dws2.UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths
End With
Application.CutCopyMode = False
' Dispay Gridlines
dws1.Activate ' ??? if "Data" or dws2.Activate ' if "GL": depending on After
dwb1.Windows(1).DisplayGridlines = False
CleanFAGL ' ??? Not knowing what this does, doesn't help.
Application.DisplayAlerts = False
swb.Close SaveChanges:=False
dwb.Close SaveChanges:=True
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I'm trying to write this little macro to copy several sheets stored in an array and paste them as values to new workbook, maintaining sheets' names and order. I've found some solutions but not exactly matching my situation.
This is for excel macro where we try sending dashboard thru mail along with attachment but need to added sheet only paste values with same formatting
Option Explicit
Sub Send_Email_With_snapshot()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Summary")
ActiveWorkbook.RefreshAll
Worksheets(Array("Calculation", "Retailer Wise_Data", "TM Wise", "Channel_Base")).Copy
Worksheets("Calculation").Range("a1:Ax54").Copy
Worksheets("Calculation").Range("a1:Ax54").PasteSpecial _
Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With ActiveWorkbook
.SaveAs Filename:="E:\Automation\New folder\" & "RAEO_Dashboard_MTD.xlsx", FileFormat:=51
.Close savechanges:=True
Application.DisplayAlerts = False
Dim lr As Integer
lr = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
sh.Range("A1:T120").Select
With Selection.Parent.MailEnvelope.Item
.to = "xyz.com"
.cc = ""
.Subject = sh.Range("AN14").Value
.attachments.Add "D:\RAEO_Dashboard_MTD.xlsx"
.send
End With
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
End With
End Sub
I wasn't sure if you meant when you wrote "with same formatting". If by that you mean cells formatting (eg. color, size, borders, visible/hidden propertie, etc.) then I added another section at the end of this answer to address that. However, if you only need number formats to stay the same, here is how you could do it.
Paste values and number formats
The 2 key elements here are:
To use .PasteSpecial Paste:=xlPasteValuesAndNumberFormats to paste values and number formats at the same time.
Use a For loop to go over your array of sheets.
Implemented this would look like this:
Sub CopySheetsValuesAndNumberFormats()
ActiveWorkbook.RefreshAll 'In case you have Pivot Tables to refresh
Dim ListOfSheets() As Variant
ListOfSheets = Array("Calculation", "Retailer Wise_Data", "TM Wise", "Channel_Base") 'Example list based on the question
Dim SourceWorkbook As Workbook
Set SourceWorkbook = ThisWorkbook 'Or Workbooks("Workbook Name")
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = Workbooks.Add
Dim i As Long
For i = LBound(ListOfSheets) To UBound(ListOfSheets)
Dim SourceSheet As Worksheet
Set SourceSheet = SourceWorkbook.Worksheets(ListOfSheets(i))
Dim DestinationSheet As Worksheet
Set DestinationSheet = DestinationWorkbook.Worksheets.Add(After:=DestinationWorkbook.Worksheets(DestinationWorkbook.Worksheets.Count)) 'Insert in last position
DestinationSheet.Name = SourceSheet.Name
Dim SourceRange As Range
Set SourceRange = SourceSheet.UsedRange
Dim DestinationRange As Range
Set DestinationRange = DestinationSheet.Range(SourceRange.Address)
'Paste values and number formats
SourceRange.Copy
DestinationRange.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Next i
'Delete initial sheets
For i = 1 To 3
On Error Resume Next
Application.DisplayAlerts = False
DestinationWorkbook.Worksheets("Sheet" & i).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Next i
End Sub
Paste values and cells formatting
In order to copy the formatting, you are going to have to copy from all Cells as opposed to from the UsedRange in the first section of this answer. The reason is that some columns might have some formatting that apply to all the cells inside a column, but not all these cells will be part of the UsedRange.
The only part of the code that you need to replace from the code above is the one starting with "Paste values and number formats". You would need to replace this part with the following:
'Paste values and cells formatting
SourceSheet.Cells.Copy
DestinationSheet.Cells.PasteSpecial Paste:=xlPasteAll
SourceRange.Copy
DestinationRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
I'm looking to do the following:
CommandButton in a destination Worksheet opens a source file (dialog box to choose which one)
Finds a worksheet (always the same name - "Performance") within the source file
Copies a range of cells (actually a couple of separate ranges - to be added)
Makes sure destination sheet (which has the same name as cell I2 in source sheet) exists
Pastes values to same ranges in destination Worksheet
Closes source file
I have this so far:
Private Sub CommandButton1_Click()
Dim SourceFile As String
Dim SourceBook As Workbook
Dim DestinationBook As Workbook
Dim desiredName As String
Set DestinationBook = ThisWorkbook
SourceFile = Application.GetOpenFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
Set SourceBook = Workbooks.Open(SourceFile)
SourceBook.Sheets("Performance").Activate
desiredName = ActiveSheet.Range("I2")
Application.CutCopyMode = True
SourceBook.ActiveSheet.Range("E25:I64").Copy
DestinationBook.Activate
If WorksheetExists = False Then
MsgBox "Couldn't find " & desiredName & " sheet within destination workbook"
Call SourceBook.Close(False)
Exit Sub
Else
Range("E25:I64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Call SourceBook.Close(False)
End If
End Sub
Function WorksheetExists() As Boolean
Dim sh As Object
For Each sh In DestinationBook.Worksheets
If sh.Name = desiredName Then WorksheetExists = True: sh.Activate
Exit For
Next
End Function
I'm getting Run-time error '424': Object Required
Any suggestions...?
Thanks in advance!
Here is a modification of your latest code. Notice these additions: 1) "Option Explicit" ensures you've properly declared all variables, 2) variables have been assigned to the important workbooks, worksheets, and ranges, 3) needed variables are passed to the WorkSheetExists function. For this to work there should be sheets named "Performance" and "testSheet" in the DestinationBook, and "testSheet" in I2 of the SourceBook. Remember, that this is just an attempt to "get you going" so I expect you'll need to modify.
Option Explicit
Sub test()
Dim SourceFile As String
Dim SourceBook As Workbook, performanceSh As Worksheet
Dim DestinationBook As Workbook
Dim desiredName As String
Set DestinationBook = ThisWorkbook
SourceFile = Application.GetOpenFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
Set SourceBook = Workbooks.Open(SourceFile)
Set performanceSh = SourceBook.Sheets("Performance")
desiredName = performanceSh.Range("I2")
Application.CutCopyMode = True
performanceSh.Range("E25:I64").Copy
If WorksheetExists(DestinationBook, desiredName) = False Then
MsgBox "Couldn't find " & desiredName & " sheet within destination workbook"
SourceBook.Close(False)
Exit Sub
Else
Range("E25:I64").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
SourceBook.Close(False)
End If
End Sub
Function WorksheetExists(destWk As Workbook, theName As String) As Boolean
Dim sh As Object
For Each sh In destWk.Worksheets
If sh.Name = theName Then WorksheetExists = True: sh.Activate
Exit For
Next
End Function
While writing a piece of code I encountered the "Subscript out of range" message.
The structure of the folder is the following:
D:\Documents main directory
Inside it there are:
the xls workbook with the code
a file 1.csv to which I need to copy data
a folder WiP which contains csv files with the data
The code currently looks like this
Sub MergeData()
'
' Ìàêðîñ1 Ìàêðîñ
' Provide path to workbooks,
' there is a folder with about 100 csv books from which I should collect data into one
Dim Filename, Pathname As String
Dim wb As Workbook
Pathname = ActiveWorkbook.Path & "\WiP\"
Filename = Dir(Pathname & "*.csv")
' Open a workbook in which the data should be pasted
Workbooks.Open ("D:\Documents\1.csv")
ActiveSheet.Cells(1, 1).Value = "date"
ActiveSheet.Cells(1, 2).Value = "hour"
ActiveSheet.Cells(1, 3).Value = "num"
ActiveSheet.Cells(1, 4).Value = "p"
' Call the code
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
IntegrateDays wb
wb.Close savechanges:=False
Filename = Dir()
Loop
' Close the workbook with data
Workbooks("D:\Documents\1.csv").Close savechanges:=True
End Sub
Sub IntegrateDays(wb As Workbook)
Dim ws As Worksheet
With wb
' Open workbooks, copy a range
Sheets(1).Activate
Dim rng As Range
Set rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
rng.Copy
' Paste the range into 1.csv
Workbooks("D:\Documents\1.csv").Worksheets(1).Range("B" & Worksheets(1).UsedRange.Rows.Count + 1).Activate
rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Set NextRow = Nothing
End With
End Sub
The code runs until it has to paste the copied range rng into 1.csv and stops with an error.
The first guess is that this may be an error related to range.activate. I attempted to test it by doing the operation without loop and only selecting one cell and further by just opening 1.csv prior to even selecting any ranges. The error remains.
The second suspicion is that there is an issue opening 1.csv. By looking though searches such as "subscript out of range opening csv" I didn't find any heavily discussed issues which would help with this question.
Could you please kindly advise me what caused the error and how to rewrite the code?
Thank you very much in advance.
Evgeniya.
You shouldn't be using rng.PasteSpecial. The parent of the Range.PasteSpecial method should be the destination; not the source.
Since you are interested in getting the values over, abandon the PasteSpecial in favor of direct value transfer.
Dim rng As Range
with Sheets(1)
Set rng = .Range(Cells(1, 1), Cells(1, 1).End(xlDown))
end with
with Workbooks("D:\Documents\1.csv").Worksheets(1)
.cells(rows.count, "B").end(xlup).offset(1,0).resize(rng.rows.count, rng.columns.count) = rng.Value
end with
Are you trying to copy from a workbook into others?
Try adjust this
Application.ScreenUpdating = False
Columns("A:C").Sort Key1:=Range("C2"), _
Order1:=xlDescending, Header:=xlYes
Application.ScreenUpdating = True
Dim WBookCopy As Workbook
Dim WBookPst As Workbook
Dim Filepath As String
Dim SheetName As String
Dim sheetCopy As Worksheet
Set WBookPst = Application.ActiveWorkbook
Call DeleteCache
'B2 is the location directory of latest Excel file
Filepath = Range("B2").Value
Set WBookCopy = Workbooks.Open(Filepath)
Set sheetPst = WBookPst.Worksheets(2)
Set sheetCopy = WBookCopy.Worksheets(1)
sheetCopy.UsedRange.Copy sheetPst.Range("A:AG")
sheetCopy.UsedRange.Value = sheetCopy.UsedRange.Value
WBookCopy.Close (False)
Suppose I have a workbook1.xlsm with multiple worksheets and full of various formulas. I want to create a new workbook2.xlsx which would look exactly the same as workbook1 but in all the cells would be values instead of formulas.
I have this macro to copy one sheet from 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.
Yet another problem is that worksheet2 is being opened afterwards. I do not want to do this.
How can I solve these problems?
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.
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
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
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, worksheet2 is actually being opened (though not named til SaveAs) as soon as you call this:
Set Output = Workbooks.Add
Just close it after saving:
Output.Close
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