How to copy only one worksheet to another workbook using vba

Question

I have 1 WorkBook("SOURCE") , which contains about 20 sheets.
I want to copy only one specific sheet into another Workbook("TARGET") using Excel VBA.

Note that the TARGET workbook does not yet exist. It must be created at runtime.

Methods Used -

1) Activeworkbook.SaveAs <--- Does not work. This will copy all the sheets. I want only a specific sheet.

Please respond to this with your valuable comments.

Thanks!

Answer 1

I have 1 WorkBook ("SOURCE"), which contains about 20 sheets. I want to copy only one specific sheet into another workbook ("TARGET") using Excel VBA. Note that the TARGET workbook does not yet exist. It must 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 book called Target.xlsx with the corresponding sheet

Answer 2

To copy a sheet into a book called TARGET:

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

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

To create a book called TARGET, you first need to add a new book and then save it to determine the file name:

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

However, this may not be ideal for you, as it will save the book in the default location, for example. My documents.

Hope this gives you something to continue.

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

In the longer example below are some useful snippets above:

• You can specify any number of sheets that you want to copy through
• You can copy whole sheets, i.e. drag the tab, or copy the contents of the cells only as values, but keep the formatting.

He can still do a lot of work to make it better (improved error handling, general cleanup), but hopefully this is a good start.

Note that not all formatting is portable, because the new sheet uses its own theme fonts and colors. I cannot decide how to copy them when you paste only the values.

  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
     'colors 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 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 colors 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