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.
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
The much longer example below combines some of the useful snippets above:
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
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
