Link to home
Start Free TrialLog in
Avatar of jnikodym
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.
Avatar of Shums Faruk
Shums Faruk
Flag of India image

Hi,

Posting a sample/dummy files would be much easier and helpful for any of us to provide you solution.
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.
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

Open in new window

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

Open in new window

Avatar of jnikodym
jnikodym

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
Shums,
  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

Open in new window

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
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 wondered why you got error, I tried here as well without error,

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

Open in new window

Copy-Multiple-Sheets-To-New-Workboo.xlsm
ASKER CERTIFIED SOLUTION
Avatar of Roy Cox
Roy Cox
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Dear Roy Cox,
Thanks for improving Input Box Method.

Regards.
jnikodym

Pleased to help