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

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

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.

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