jnikodym
asked on
Excel VBA - Copy worksheet from one file to a new file, paste as values and column widths
I have an excel file that i would like to create a button on, that will copy a certain worksheet and then open a new excel file and do a paste special onto the new worksheet to only paste the values. I would also like the existing worksheets column widths copied to the new sheet as well.
hi.
I just write the code for you, and tested.
Sub CopySheet()
Dim SheetName As String
SheetName = InputBox("Type the sheet name, you want to copy:", "Copy Sheet")
Sheets(SheetName).Select
ActiveSheet.Copy Before:=Sheets(1)
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveSheet.Move
ActiveSheet.Name = SheetName
MsgBox "Done"
End Sub
now create a button and link it with this macro/sub.
I just write the code for you, and tested.
Sub CopySheet()
Dim SheetName As String
SheetName = InputBox("Type the sheet name, you want to copy:", "Copy Sheet")
Sheets(SheetName).Select
ActiveSheet.Copy Before:=Sheets(1)
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveSheet.Move
ActiveSheet.Name = SheetName
MsgBox "Done"
End Sub
now create a button and link it with this macro/sub.
Below is sample code, you may need to change variables which suits you:
Sub SampleMacro()
Dim FName As String
Dim Sh As Worksheet
Application.ScreenUpdating = False
FName = "MyBook" & Format(Now(), "dd-mmm-yyyy") 'Change Filename which suits you
If Dir("C:\" & FName & ".xlsx") = vbNullString Then
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy 'Change the sheet names as required
For Each Sh In ActiveWorkbook.Worksheets
With Cells
.Copy
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
End With
Range("A1").Select
Next Sh
ActiveWorkbook.SaveAs "C:\" & FName & ".xlsx", xlNormal
End If
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub
EDITED:
Sub SampleMacro()
Dim FName As String
Dim Sh As Worksheet
Application.ScreenUpdating = False
FName = "MyBook" & Format(Now(), "dd-mmm-yyyy") 'Change Filename which suits you
If Dir("C:\" & FName & ".xlsx") = vbNullString Then
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy 'Change the sheet names as required
For Each Sh In ActiveWorkbook.Worksheets
With Cells
.Copy
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
End With
Range("A1").Select
Next Sh
ActiveWorkbook.SaveAs "C:\" & FName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub
ASKER
Vikas, that just creates a copy on the same workbook. I need it to open a new file and create a copy on the new file
ASKER
Shums,
I don't want to save the new file, i just want it to open a new file and copy the sheet.
I don't want to save the new file, i just want it to open a new file and copy the sheet.
Then testing code would be:
Sub SampleMacro()
Dim SrcWB As Workbook, TrgtWB As Workbook
Dim Sh As Worksheet
Dim MyArray As Variant
Application.ScreenUpdating = False
MyArray = Array("Sheet1", "Sheet2", "Sheet3") 'Change the sheet names as required
Set SrcWB = ThisWorkbook
Set TrgtWB = Workbooks.Add
SrcWB.Worksheets(MyArray).Copy before:=TrgtWB.Worksheets(1)
For Each Sh In SrcWB.Worksheets
With Cells
.Copy
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
End With
Range("A1").Select
Next Sh
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub
Sub CopySheet()
Dim SheetName As String
SheetName = InputBox("Type the sheet name, you want to copy:", "Copy Sheet")
Sheets(SheetName).Select
ActiveSheet.Copy Before:=Sheets(1) '' this will create a duplicate copy of your desired sheet in the same workbook
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues '''''all the values PasteSpecial
Application.CutCopyMode = False
ActiveSheet.Move '''''this will Open a New WorkBook and move the duplicate Pastespecial sheet to this New Workbook
ActiveSheet.Name = SheetName ''''Duplicate Sheet name will become as Original
MsgBox "Done"
End Sub
Sample-File.xlsb
Dim SheetName As String
SheetName = InputBox("Type the sheet name, you want to copy:", "Copy Sheet")
Sheets(SheetName).Select
ActiveSheet.Copy Before:=Sheets(1) '' this will create a duplicate copy of your desired sheet in the same workbook
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues '''''all the values PasteSpecial
Application.CutCopyMode = False
ActiveSheet.Move '''''this will Open a New WorkBook and move the duplicate Pastespecial sheet to this New Workbook
ActiveSheet.Name = SheetName ''''Duplicate Sheet name will become as Original
MsgBox "Done"
End Sub
Sample-File.xlsb
ASKER
Shums,
I get a Run-time error '9' Subscript out of range on the follwoing line
SrcWB.Worksheets(MyArray). Copy before:=TrgtWB.Worksheets( 1)
I get a Run-time error '9' Subscript out of range on the follwoing line
SrcWB.Worksheets(MyArray).
I wondered why you got error, I tried here as well without error,
Please find attached...
Copy-Multiple-Sheets-To-New-Workboo.xlsm
Please find attached...
Copy-Multiple-Sheets-To-New-Workboo.xlsm
OK here is improved version, which will delete extra sheets which are not like copied sheets:
Sub SampleMacro()
Dim SrcWB As Workbook, TrgtWB As Workbook
Dim Sh As Worksheet
Dim MyArray As Variant, ShName As Variant
Dim Matched As Boolean
Application.ScreenUpdating = False
MyArray = Array("MySheet1", "MySheet2", "MySheet3") 'Change the sheet names as required
Set SrcWB = ThisWorkbook
Set TrgtWB = Workbooks.Add
Application.CopyObjectsWithCells = False
SrcWB.Worksheets(MyArray).Copy Before:=TrgtWB.Worksheets(1)
Application.CopyObjectsWithCells = True
For Each Sh In TrgtWB.Worksheets
With Cells
.Copy
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteColumnWidths
End With
Range("A1").Select
Matched = False
For Each ShName In MyArray
If ShName = Sh.Name Then
Matched = True
Exit For
End If
Next
If Not Matched Then
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End If
Next Sh
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub
Copy-Multiple-Sheets-To-New-Workboo.xlsm
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Dear Roy Cox,
Thanks for improving Input Box Method.
Regards.
Thanks for improving Input Box Method.
Regards.
jnikodym
Pleased to help
Pleased to help
Posting a sample/dummy files would be much easier and helpful for any of us to provide you solution.