Copy sheets between workbokks in VBA

tombrown · Sep 5, 2006

How do I copy sheets between workbooks in VBA?

I want to copy a number of individual sheest from wbCurrent to wbNew (both declared as workbooks) I tried this ... but it didnt work

wbCurrent.Sheets("PCO Mth").Copy wbNew

thanks

Oorang · Sep 5, 2006

Hi,
Your argument (wbNew) needs to specify not just the workbook you want to copy it to, but the sheet you want to copy it before or after. (Before is the default, but it's usually easier to read if you name the argument.)

Code:

wbCurrent.Sheets("PCO Mth").Copy Before:=wbNew.Sheets(1)

tombrown · Sep 5, 2006

Thanks - this worked,

but now I have another issue.

Some of the sheets in the original workbook include formulas &/or charts based on data in other sheets in the same workbook. I want to copy them all across, but I want to formulae and charts to reference the copied sheets in the new workbook .... at the moment they refer back to the original sheet. Is there an argument to achieve this?

tombrown · Sep 5, 2006

Another possibility would be to use SaveAs method, but I woudl like to remove all the VBA modules and some of the sheets when the file is saved ... how can I do that?

Oorang · Sep 5, 2006

Hmmm, probably the easiest way to do that would be to just clone your workbook. I have some code from an add-in I built a while back that might be helpful to you. but it will leave teh VBA modules in. I will post back in with cod eto strip the VBA modules.<hr>
Option Explicit
Sub BackupWorkBook()
'This code was originally written by Aaron Bush 2006
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copywrite notice is left unchanged.
'
'Code Courtesy of
'Aaron Bush
'
'Copywrite verbage courtesy of Dev Ashish
On Error GoTo Err_Hnd
Dim fso As Scripting.FileSystemObject 'Requires reference to Microsoft Scripting Runtime
Dim strFileName As String 'Holds the File name.
Dim bytMsgBox As Byte 'Holds the users response to message boxes.
Dim boolGotFileName As Boolean 'Determines
Set fso = New Scripting.FileSystemObject
Do
 strFileName = Excel.Application.GetSaveAsFilename(ThisWorkbook.Name, "Microsoft Excel Workbook (*.xls),*.xls", Title:="Select location to copy current workbook to:")
 If strFileName = "False" Then Exit Sub
 If strFileName = ThisWorkbook.FullName Then
 boolGotFileName = False
 MsgBox "Cannot copy a file to the same location as itself.", vbExclamation, "Invalid Location"
 Else
 If fso.FileExists(strFileName) Then
 bytMsgBox = MsgBox("A file already exists in that location, do you wish to overwrite it?", vbQuestion + vbYesNoCancel, "Confirm Overwrite")
 Select Case bytMsgBox
 Case vbCancel
 Exit Sub
 Case vbNo
 boolGotFileName = False
 Case vbYes
 boolGotFileName = True
 Case Else
 MsgBox "Unexpected response. Operation aborted.", vbExclamation, "Invalid Response"
 Exit Sub
 End Select
 Else
 boolGotFileName = True
 End If
 End If
Loop Until boolGotFileName
ThisWorkbook.Save
fso.CopyFile ThisWorkbook.FullName, strFileName, True
MsgBox "Backup complete.", vbInformation, "File Copied"
Exit Sub
Err_Hnd:
MsgBox Err.Description, vbCritical, "Error: " & Err.Number
End Sub

tombrown · Sep 5, 2006

Looks good - I am eagerly anticipating the code to strip out the modules ... many thanks.

Only caveat is that I dont want to save the original file, only the cloned version, so shoudl I leave out the ThisWorkbook.Save?

[Reason is that I have a template work book with the VBA and chart templates included. The code pulls in data from various sources and formats it into the charts. I then want to save off a copy & return the template workbook to its original data-less state]

Oorang · Sep 5, 2006

Ok here is a version more directed to your task. I have break tested it as much as I could, but I would advise doing a little testing of your own before you release it into "the wild". Run the "CleanBackup" sub.
note: You may have to change your security settings to allow trusted access to the vba project.<hr>
Option Explicit
Const strFalse As String = "False" 'String version of false
Sub CleanBackUp()
Dim strFileName As String 'Holds the name of the file you want to make a copy of.
Dim strNewFileName As String 'Holds the name of the copy you intend to create.
Dim wbCopy As Excel.Workbook 'The Workbook object of the copy you inted to make.
Dim strFlExt As String 'Holds the extension of the file to be backed up.
Dim bytMsgBox As Byte 'Hold the users response to message boxes.
'This code was originally written by Aaron Bush 2006
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copywrite notice is left unchanged.
'
'Code Courtesy of
'Aaron Bush
'
'Copywrite verbage courtesy of Dev Ashish
On Error GoTo Err_Hnd
'Get name of file to be backed up.
strFileName = Application.GetOpenFilename(Title:="Select file to backup:")
If strFileName = strFalse Then Exit Sub
'Check to see if workbook selected is opened:
If WorkBookOpened(strFileName) Then
 'If it is open then save it so no changes are lost.
 bytMsgBox = MsgBox("The workbook you have selected is still open. Do you wish to save it so the most recent version will be backed up?", vbQuestion + vbYesNoCancel, "Workbook Open")
 Select Case bytMsgBox
 Case vbYes
 Excel.Application.Workbooks(Mid$(strFileName, InStrRev(strFileName, "\") + 1)).Save
 Case vbNo: 'Do nothing
 Case vbCancel: Exit Sub
 Case Else
 MsgBox "Unexpected response. Operation aborted.", vbExclamation, "Invalid Response"
 Exit Sub
 End Select
 End If
'Get file extention of filename. This will allow us to set the filter to the same extention. Thereby allowing us
'to force the same filetype.
strFlExt = VBA.Right$(strFileName, 3)
'Get the name of the copy you intend to create.
strNewFileName = Application.GetSaveAsFilename(FileFilter:=", *." & strFlExt, Title:="Select new file name:")
If strNewFileName = strFalse Then Exit Sub
'Create a copy of the target workbook.
If BackupWorkBook(strFileName, strNewFileName, False) = False Then
 MsgBox "Backup Failed", vbExclamation, "Operation Aborted"
 Exit Sub
 End If
'Open copy
Application.ScreenUpdating = False
Set wbCopy = Excel.Application.Workbooks.Open(strNewFileName)
Excel.Windows(wbCopy.Name).Visible = False
Application.ScreenUpdating = True
'Sub VBA from copy
StripVBA wbCopy, False
wbCopy.Close savechanges:=True
Exit Sub
Err_Hnd:
MsgBox Err.Description, vbCritical, "Error: " & Err.Number
End Sub
Function BackupWorkBook(ByVal strFileName As String, ByVal strNewFileName As String, _
Optional ByVal boolSilent As Boolean = False) As Boolean
'This code was originally written by Aaron Bush 2006
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copywrite notice is left unchanged.
'
'Code Courtesy of
'Aaron Bush
'
'Copywrite verbage courtesy of Dev Ashish
On Error GoTo Err_Hnd
Dim fso As Scripting.FileSystemObject 'Requires reference to Microsoft Scripting Runtime
Dim bytMsgBox As Byte 'Holds the users response to message boxes.
Dim boolGotFileName As Boolean 'Informs if a valid file name was received.
Set fso = New Scripting.FileSystemObject
'Make sure a valid file name was recieved.
If strFileName = strFalse Or strNewFileName = strFalse Then Exit Function
If strFileName = strNewFileName Then
 MsgBox "Cannot copy a file to the same location as itself.", vbExclamation, "Invalid Location"
 Else
 If fso.FileExists(strNewFileName) Then
 If Not boolSilent Then bytMsgBox = MsgBox("A file already exists in that location, do you wish to overwrite it?", vbQuestion + vbYesNoCancel, "Confirm Overwrite")
 Select Case bytMsgBox
 Case vbCancel: Exit Function
 Case vbNo: boolGotFileName = False
 Case vbYes
 If WorkBookOpened(strNewFileName) Then
 If Not boolSilent Then MsgBox "Cannot overwrite a file that is open. Please close the file and try again.", vbExclamation, "Overwrite Failed"
 Exit Function
 Else
 boolGotFileName = True
 End If
 Case Else
 If Not boolSilent Then MsgBox "Unexpected response. Operation aborted.", vbExclamation, "Invalid Response"
 Exit Function
 End Select
 Else: boolGotFileName = True
 End If
 End If
If Not boolGotFileName Then Exit Function
fso.CopyFile Source:=strFileName, Destination:=strNewFileName, OverWriteFiles:=True
BackupWorkBook = True
If Not boolSilent Then MsgBox "Backup complete.", vbInformation, "File Copied"
Exit Function
Err_Hnd:
BackupWorkBook = False
MsgBox Err.Description, vbCritical, "Error: " & Err.Number
End Function
Sub StripVBA(wbTarget As Excel.Workbook, Optional ByVal boolRmvForms As Boolean = False)
'This code was originally written by Aaron Bush 2006
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copywrite notice is left unchanged.
'
'Code Courtesy of
'Aaron Bush
'
'Copywrite verbage courtesy of Dev Ashish
'Needs reference to Microsoft Visual Basic For Applications Extensibility library
Dim proj As VBIDE.VBProject
Dim cmp As VBIDE.VBComponent
Dim lngCOL As Long 'Count of project lines
Dim bytCompType As Byte 'Holds the current component type
Set proj = wbTarget.VBProject
On Error GoTo Err_Hnd
'Remove Standard Modules and clean Document Modules
For Each cmp In proj.VBComponents
 bytCompType = cmp.Type
 If bytCompType = vbext_ct_StdModule Then proj.VBComponents.remove cmp
 If bytCompType = vbext_ct_Document Then
 lngCOL = cmp.CodeModule.CountOfLines
 If lngCOL <> 0 Then
 cmp.CodeModule.DeleteLines 1, lngCOL
 End If
 End If
 If boolRmvForms And bytCompType = vbext_ct_MSForm Then proj.VBComponents.remove cmp
Next cmp
Exit Sub
Err_Hnd:
MsgBox Err.Description, vbCritical, "Error: " & Err.Number
End Sub
Function WorkBookOpened(ByVal strFileName As String) As Boolean
Dim wb As Excel.Workbook
For Each wb In Excel.Workbooks
If wb.FullName = strFileName Then
 WorkBookOpened = True
 Exit For
 End If
Next wb
End Function

tombrown · Sep 6, 2006

Apologies for not replying, I am currently travelling.

This is brilliant - many thanks. I will try it out as soon as I get back to the office

Copy sheets between workbokks in VBA

tombrown

Board Regular

Excel Facts

Oorang

Well-known Member

tombrown

Board Regular

tombrown

Board Regular

Oorang

Well-known Member

tombrown

Board Regular

Oorang

Well-known Member

tombrown

Board Regular

Similar threads

Forum statistics

Share this page

Copy sheets between workbokks in VBA

Board Regular

Excel Facts

Well-known Member

Board Regular

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock