How to copy only a single worksheet to another workbook using vba

Question

I have 1 WorkBook("SOURCE") that contains around 20 Sheets.
I want to copy only 1 particular sheet to another Workbook("TARGET") using Excel VBA.

Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.

Methods Used -

1) Activeworkbook.SaveAs <--- Doesn't work. This will copy all the sheets. I want only specific sheet.

Answer 1

I have 1 WorkBook("SOURCE") that contains around 20 Sheets. I want to copy only 1 particular sheet to another Workbook("TARGET") using Excel VBA. Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.

Another Way

Sub Sample()
    '~~> Change Sheet1 to the relevant sheet
    '~~> This will create a new workbook with the relevant sheet
    ThisWorkbook.Sheets("Sheet1").Copy

    '~~> Save the new workbook
    ActiveWorkbook.SaveAs "C:\Target.xlsx", FileFormat:=51
End Sub

This will automatically create a new workbook called Target.xlsx with the relevant sheet

Answer 2

To copy a sheet to a workbook called TARGET:

Sheets("xyz").Copy After:=Workbooks("TARGET.xlsx").Sheets("abc")

This will put the copied sheet xyz in the TARGET workbook after the sheet abc Obviously if you want to put the sheet in the TARGET workbook before a sheet, replace Before for After in the code.

To create a workbook called TARGET you would first need to add a new workbook and then save it to define the filename:

Application.Workbooks.Add (xlWBATWorksheet)
ActiveWorkbook.SaveAs ("TARGET")

However this may not be ideal for you as it will save the workbook in a default location e.g. My Documents.

Hopefully this will give you something to go on though.

Answer 3

You can try this VBA program

Option Explicit 

Sub CopyWorksheetsFomTemplate() 
    Dim NewName As String 
    Dim nm As Name 
    Dim ws As Worksheet 

    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ 
    "New sheets will be pasted as values, named ranges removed" _ 
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub 

    With Application 
        .ScreenUpdating = False 

         '       Copy specific sheets
         '       *SET THE SHEET NAMES TO COPY BELOW*
         '       Array("Sheet Name", "Another sheet name", "And Another"))
         '       Sheet names go inside quotes, seperated by commas
        On Error GoTo ErrCatcher 
        Sheets(Array("Sheet1", "Sheet2")).Copy 
        On Error GoTo 0 

         '       Paste sheets as values
         '       Remove External Links, Hperlinks and hard-code formulas
         '       Make sure A1 is selected on all sheets
        For Each ws In ActiveWorkbook.Worksheets 
            ws.Cells.Copy 
            ws.[A1].PasteSpecial Paste:=xlValues 
            ws.Cells.Hyperlinks.Delete 
            Application.CutCopyMode = False 
            Cells(1, 1).Select 
            ws.Activate 
        Next ws 
        Cells(1, 1).Select 

         '       Remove named ranges
        For Each nm In ActiveWorkbook.Names 
            nm.Delete 
        Next nm 

         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy") 

         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls" 
        ActiveWorkbook.Close SaveChanges:=False 

        .ScreenUpdating = True 
    End With 
    Exit Sub 

ErrCatcher: 
    MsgBox "Specified sheets do not exist within this workbook" 

End Sub 

Answer 4

The much longer example below combines some of the useful snippets above:

• You can specify any number of sheets you want to copy across
• You can copy entire sheets, i.e. like dragging the tab across, or you can copy over the contents of cells as values-only but preserving formatting.

It could still do with a lot of work to make it better (better error-handling, general cleaning up), but it hopefully provides a good start.

Note that not all formatting is carried across because the new sheet uses its own theme's fonts and colours. I can't work out how to copy those across when pasting as values only.

 Option Explicit

Sub copyDataToNewFile()
    Application.ScreenUpdating = False

    ' Allow different ways of copying data:
    ' sheet = copy the entire sheet
    ' valuesWithFormatting = create a new sheet with the same name as the
    '                        original, copy values from the cells only, then
    '                        apply original formatting. Formatting is only as
    '                        good as the Paste Special > Formats command - theme
    '                        colours and fonts are not preserved.
    Dim copyMethod As String
    copyMethod = "valuesWithFormatting"

    Dim newFilename As String           ' Name (+optionally path) of new file
    Dim themeTempFilePath As String     ' To temporarily save the source file's theme

    Dim sourceWorkbook As Workbook      ' This file
    Set sourceWorkbook = ThisWorkbook

    Dim newWorkbook As Workbook         ' New file

    Dim sht As Worksheet                ' To iterate through sheets later on.
    Dim sheetFriendlyName As String     ' To store friendly sheet name
    Dim sheetCount As Long              ' To avoid having to count multiple times

    ' Sheets to copy over, using internal code names as more reliable.
    Dim colSheetObjectsToCopy As New Collection
    colSheetObjectsToCopy.Add Sheet1
    colSheetObjectsToCopy.Add Sheet2

    ' Get filename of new file from user.
    Do
        newFilename = InputBox("Please Specify the name of your new workbook." & vbCr & vbCr & "Either enter a full path or just a filename, in which case the file will be saved in the same location (" & sourceWorkbook.Path & "). Don't use the name of a workbook that is already open, otherwise this script will break.", "New Copy")
        If newFilename = "" Then MsgBox "You must enter something.", vbExclamation, "Filename needed"
    Loop Until newFilename > ""

    ' If they didn't supply a path, assume same location as the source workbook.
    ' Not perfect - simply assumes a path has been supplied if a path separator
    ' exists somewhere. Could still be a badly-formed path. And, no check is done
    ' to see if the path actually exists.
    If InStr(1, newFilename, Application.PathSeparator, vbTextCompare) = 0 Then
        newFilename = sourceWorkbook.Path & Application.PathSeparator & newFilename
    End If

    ' Create a new workbook and save as the user requested.
    ' NB This fails if the filename is the same as a workbook that's
    ' already open - it should check for this.
    Set newWorkbook = Application.Workbooks.Add(xlWBATWorksheet)
    newWorkbook.SaveAs Filename:=newFilename, _
        FileFormat:=xlWorkbookDefault

    ' Theme fonts and colours don't get copied over with most paste-special operations.
    ' This saves the theme of the source workbook and then loads it into the new workbook.
    ' BUG: Doesn't work!
    'themeTempFilePath = Environ("temp") & Application.PathSeparator & sourceWorkbook.Name & " - Theme.xml"
    'sourceWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
    'sourceWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
    'newWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
    'newWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath
    'On Error Resume Next
    'Kill themeTempFilePath  ' kill = delete in VBA-speak
    'On Error GoTo 0


    ' getWorksheetNameFromObject returns null if the worksheet object doens't
    ' exist
    For Each sht In colSheetObjectsToCopy
        sheetFriendlyName = getWorksheetNameFromObject(sourceWorkbook, sht)
        Application.StatusBar = "VBL Copying " & sheetFriendlyName
        If Not IsNull(sheetFriendlyName) Then
            Select Case copyMethod
                Case "sheet"
                    sourceWorkbook.Sheets(sheetFriendlyName).Copy _
                        After:=newWorkbook.Sheets(newWorkbook.Sheets.count)
                Case "valuesWithFormatting"
                    newWorkbook.Sheets.Add After:=newWorkbook.Sheets(newWorkbook.Sheets.count), _
                        Type:=sourceWorkbook.Sheets(sheetFriendlyName).Type
                    sheetCount = newWorkbook.Sheets.count
                    newWorkbook.Sheets(sheetCount).Name = sheetFriendlyName
                    ' Copy all cells in current source sheet to the clipboard. Could copy straight
                    ' to the new workbook by specifying the Destination parameter but in this case
                    ' we want to do a paste special as values only and the Copy method doens't allow that.
                    sourceWorkbook.Sheets(sheetFriendlyName).Cells.Copy ' Destination:=newWorkbook.Sheets(newWorkbook.Sheets.Count).[A1]
                    newWorkbook.Sheets(sheetCount).[A1].PasteSpecial Paste:=xlValues
                    newWorkbook.Sheets(sheetCount).[A1].PasteSpecial Paste:=xlFormats
                    newWorkbook.Sheets(sheetCount).Tab.Color = sourceWorkbook.Sheets(sheetFriendlyName).Tab.Color
                    Application.CutCopyMode = False
            End Select
        End If
    Next sht

    Application.StatusBar = False
    Application.ScreenUpdating = True
    ActiveWorkbook.Save

Answer 5

Sub ActiveSheet_toDESKTOP_As_Workbook()

Dim Oldname As String
Dim MyRange As Range
Dim MyWS As String

MyWS = ActiveCell.Parent.Name

    Application.DisplayAlerts = False 'hide confirmation from user
    Application.ScreenUpdating = False
    Oldname = ActiveSheet.Name
    'Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet"
    
    'Get path for desktop of user PC
    Path = Environ("USERPROFILE") & "\Desktop"
    

    ActiveSheet.Cells.Copy
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "TransferSheet"
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells.Copy
    
    'Create new workbook and past copied data in new workbook & save to desktop
    Workbooks.Add (xlWBATWorksheet)
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveSheet.Cells(1, 1).Select
    ActiveWorkbook.ActiveSheet.Name = Oldname    '"report"
    ActiveWorkbook.SaveAs Filename:=Path & "\" & Oldname & " WS " & Format(CStr(Now()), "dd-mmm (hh.mm.ss AM/PM)") & ".xlsx"
    ActiveWorkbook.Close SaveChanges:=True

    
    Sheets("TransferSheet").Delete
    
    
   Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Worksheets(MyWS).Activate
    'MsgBox "Exported to Desktop"

End Sub