VBA to save a copy of a workbook with a cell reference including macros

[Hydra]

Hi Everyone!

This is my first post here, and I am quite new to VBA, I could do with some help / advise please.

I have a book that contains multiple sheets with user login / permissions. I need to save a copy of the ( current ) open workbook in .xlsm-format ( including the macros ), with a name ref from cell "Z6" and remove one sheet from the copy ( this sheet has information that is not needed on any of the saved copies ). I kind of have it working, but it is not saving the "Modules" or the "Form".

This is the code that I am currently using:

//////////////////////////////////////////

Sub SaveFileCopy()
Dim x As Integer
Dim FileName As String, FilePath As String
Dim NewWorkBook As Workbook, OldWorkBook As Workbook

Set OldWorkBook = ThisWorkbook

With Application
.ScreenUpdating = False: .DisplayAlerts = False
End With

On Error Resume Next
With OldWorkBook.Sheets("Reception Sheet")
FilePath = "C:\HDMS\JOBS\" & .Range("Z6").Value
FileName = .Range("Z6").Value & ".xlsm"
End With

MkDir FilePath
On Error GoTo -1

On Error GoTo myerror
FilePath = FilePath & "\"

For x = 2 To OldWorkBook.Worksheets.Count
With OldWorkBook.Worksheets(x)
If Not NewWorkBook Is Nothing Then
.Copy after:=NewWorkBook.Worksheets(NewWorkBook.Worksheets.Count)
Else
.Copy
Set NewWorkBook = ActiveWorkbook
End If
End With
Next x

NewWorkBook.SaveAs FilePath & FileName, 52

myerror:
If Not NewWorkBook Is Nothing Then NewWorkBook.Close False
With Application
.ScreenUpdating = True: .DisplayAlerts = True
End With
If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

//////////////////////////////////////////

Any help would be awesome
Thanks
Anton

 

[Domenic]

I would suggest going about it a bit differently. First, save a copy of the entire workbook using the SaveCopyAs method of the Workbook object. Then, open the saved copy of the workbook, then delete the first worksheet, and then Save and Close the workbook. Note that if a workbook by the same name already exists in the destination folder, the existing file will automatically be overwritten.

Option Explicit

Sub SaveFileCopy()

    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
   
    Dim mainFolderPath As String
    mainFolderPath = "C:\HDMS\JOBS\"
    If Len(Dir(mainFolderPath, vbDirectory)) = 0 Then
        MsgBox mainFolderPath & " does not exist!", vbExclamation
        Exit Sub
    End If
   
    Dim oldWorkbook As Workbook
    Set oldWorkbook = ThisWorkbook
   
    Dim filePath As String
    Dim fileName As String
    With oldWorkbook.Sheets("Reception Sheet")
        filePath = mainFolderPath & .Range("Z6").Value & "\"
        If Len(Dir(filePath, vbDirectory)) = 0 Then
            MkDir filePath
        End If
        fileName = .Range("Z6").Value & ".xlsm"
    End With
   
    oldWorkbook.SaveCopyAs filePath & fileName
   
    Dim newWorkbook As Workbook
    Set newWorkbook = Workbooks.Open(filePath & fileName)
   
    newWorkbook.Worksheets(1).Delete
   
    newWorkbook.Close savechanges:=True
   
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With

End Sub

Hope this helps!