PDA

View Full Version : [SOLVED] VBA Help - Code to create a copy of a macro enabled workbook



SarahBear
03-31-2016, 12:56 AM
Hi, Newbie here!

I'm really hoping someone can help me with this. I have a basic understanding of VBA but I'm definitely stuck with this one.

The below code works perfectly for what I want it to do at the moment - it creates a copy of a worksheet to a specified folder with a specified name which is determined by formulas on C98 and C99 (on tabs Call 1 - Call 5) of the attached workbook.

However, what I want to do is to create a copy of the entire workbook, using the same formula, and to make sure that the copy is macro-enabled.

I've included all of the code as I'm not entirely sure where I need to start this from but I'm guessing from the section that starts 'ThisWorkbook.Sheets...'

I have googled extensively but nothing I've found seems to quite fit what I want so any help would be greatly appreciated :)



Option Explicit


Sub CreateAgentCopy()
If IsEmpty(Cells(2, 4)) Then
MsgBox "You must complete Agent Name"
ElseIf IsEmpty(Cells(4, 4)) Then
MsgBox "You must complete Team Leader name"
ElseIf IsEmpty(Cells(7, 4)) Then
MsgBox "You must complete Evaluation Date"
Else
Dim NewFn As String
Dim NewWB As Workbook
Dim SubDirectories() As String
Dim i As Integer
Dim SubDirBuild As String
Dim ssh As String


Application.ScreenUpdating = False


ssh = Range("D86").Value
NewFn = Range("D87").Value

SubDirectories = Split(Range("D86"), "\")

'If Directory specified then place at begining of string otherwise
'the current Directory will be used
If Right(SubDirectories(0), 1) = ":" Then SubDirBuild = SubDirectories(0)

'Add each subdirectory to string and try to make a subdirectory
For i = LBound(SubDirectories) + 1 To UBound(SubDirectories)
SubDirBuild = SubDirBuild & "\" & SubDirectories(i)
'MsgBox SubDirBuild
On Error Resume Next
MkDir SubDirBuild
Next i


Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ssh & NewFn


Set NewWB = ActiveWorkbook


ThisWorkbook.Sheets("Planning_Form").Copy Before:=NewWB.Sheets("Sheet1")
NewWB.ActiveSheet.Buttons.Visible = False


ActiveWorkbook.Close True
NewWB.Close Savechanges:=True


MsgBox "Copy routine completed"


End If
End Sub

mancubus
03-31-2016, 01:46 AM
welcome to VBAX.

use SaveCopyAs method.

https://msdn.microsoft.com/en-us/library/bb178003(v=office.12).aspx

SarahBear
03-31-2016, 03:33 AM
Thanks, mancubus!

I've replaced...



Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ssh & NewFn


Set NewWB = ActiveWorkbook


ThisWorkbook.Sheets("Planning_Form").Copy Before:=NewWB.Sheets("Sheet1")
NewWB.ActiveSheet.Buttons.Visible = False


ActiveWorkbook.Close True
NewWB.Close Savechanges:=True

with...



Workbooks.Add
ActiveWorkbook.SaveCopyAs Filename:=ssh & NewFn


'Set NewWB = ActiveWorkbook


'ThisWorkbook.Sheets("Planning_Form").Copy Before:=NewWB.Sheets("Sheet1")
'NewWB.ActiveSheet.Buttons.Visible = False


ActiveWorkbook.Close True
NewWB.Close Savechanges:=True

This does create a file to the specified folder with the correct file name which is perfect but it isn't an Excel file. Under the file type it just says 'File' and it can't be opened. I'm clearly missing something somewhere! Any suggestions?

mancubus
03-31-2016, 04:06 AM
You are welcome.
"Add" method adds a blank workbook.
If this is what you are after then use SaveAs method.

use SaveCopyAs method for existing files, especially for a backup of the file you are currently working with.
if you use a variable for the file name, make sure that variable contains the file extension.

to create a copy of the entire workbook;

same folder


With ThisWorkbook
.Save
BackUpFileName = Replace(.FullName, ".xlsm", "_BackUp.xlsm")
.SaveCopyAs Filename:=BackUpFileName
End With


another folder


DestionationFolder = "C:\MyFolder\MySubfolder\" 'dont forget adding \ at the end of the folder name.
With ThisWorkbook
.Save
BackUpFileName = DestionationFolder & Replace(.Name, ".xlsm", "_BackUp.xlsm")
.SaveCopyAs Filename:=BackUpFileName
End With


PS: regarding the file you have uploaded, cells D86 and D87 are blank.

SarahBear
03-31-2016, 07:58 AM
That works perfectly, you are a star!

Thank you so much :biggrin:

mancubus
03-31-2016, 10:15 AM
you are welcome.

thanks for the feedback and marking the thread as solved.