VBA Help - Code to create a copy of a macro enabled workbook

[SarahBear]

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]

welcome to VBAX.

use SaveCopyAs method.

https://msdn.microsoft.com/en-us/lib...ffice.12).aspx

[SarahBear]

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]

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]

That works perfectly, you are a star!

Thank you so much

[mancubus]

you are welcome.

thanks for the feedback and marking the thread as solved.