Save copy automatically as .xlsm

[Nikko]

Hi all



Found this VBA code in the Internet (don’t remember where) is really great ... only it saves in .xlsx format.



What i need: each time I want to save or close the file, an exactly the same file (with all macros .. as a “saving as” command) should be created as a full backup of this file.

At the same time, is it possible to save the same code in .xlsm format?

.. and if possible automatically adds the date in the saved name?

Option Explicit



Private Sub Workbook_BeforeClose(Cancel As Boolean)



    Dim WbZ As Workbook

    Dim Pfad$, Dname$, Info



    Pfad = "\\WDMYCLOUD\Team\0 Niko\PLANER\Planer 2020\Backup"

    Dname = "Backup.xlsm"



    Application.ScreenUpdating = False

    Application.DisplayAlerts = False



    With Me

        If Not .ReadOnly Then

            Select Case .Saved

                Case Is = False

                    Info = MsgBox("Die Mappe wurde noch nicht gespeichert." & vbLf & _

                        "Soll diese Mappe gespeichert werden?", vbYesNo, _

                        "Schließen und Speichern?")

                    'Wenn Mappe vor dem Schließen gespeichert wird,

                    'dann Sicherheitskopie

                    If Info = vbYes Then

                        .Save

                        .Sheets.Copy

                        Set WbZ = ActiveWorkbook

                        With WbZ

                            .SaveAs Filename:=Pfad & Dname, _

                            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

                            .Close True

                        End With

                        .Close

                    'Wenn Mappe vor dem SChließen NICHT gespeichert wird,

                    'dann KEINE Sicherheitskopie

                    Else:

                        .Saved = True

                        .Close

                    End If

                'Mappe wurde NICHT geändert oder bereits gespeichert

                'Dann KEINE Sicherheitskopie

            End Select

        End If

    End With



    Application.ScreenUpdating = True

    Application.DisplayAlerts = True



End Sub

Can someone help me? Thank you in advance

 

[AlphaFrog]

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    
    Dim Pfad$, Dname$
    
    Pfad = "\\WDMYCLOUD\Team\0 Niko\PLANER\Planer 2020\Backup\"
    Dname = "Backup" & Format(Date, "yyyy-mm-dd") & ".xlsm"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    With Me
        If Not .ReadOnly And Not .Saved Then
            If MsgBox("Die Mappe wurde noch nicht gespeichert." & vbLf & _
                          "Soll diese Mappe gespeichert werden?", vbYesNo, _
                          "Schließen und Speichern?") = vbYes Then
            
            'Wenn Mappe vor dem Schließen gespeichert wird,
            'dann Sicherheitskopie
            .SaveCopyAs Filename:=Pfad & Dname
            
            'Wenn Mappe vor dem SChließen NICHT gespeichert wird,
            'dann KEINE Sicherheitskopie
            Else
                .Saved = True
                .Close
            End If
                
            'Mappe wurde NICHT geändert oder bereits gespeichert
            'Dann KEINE Sicherheitskopie
        End If
    End With
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

 

[GWteB]

I'm not sure you want to save the file your code is in, or a (random) other file.
In the first case, your workbook already would have an *.xlsm extension, in the second case replace the line
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
with
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

 

[Nikko]

I think I made a mistake when sending the VBA code, I forgot a part. Here is all the code.

Option Explicit


Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Prüft vor dem Schließen dieser Mappe ob Änderungen vorliegen/gespeichert wurde
'Liegen Änderungen vor bzw. wurde noch nicht gespeichert, kann gewählt werden ob
'diese Mappe gespeichert wird - ja speichert Mappe + Sicherheitskopie, nein speichert
'weder diese Mappe noch Sicherheitskopie
'Wurde Mappe vor dem Schließen nicht verändert bzw. bereits gespeichert, dann wird keine
'Sicherheitskopie erstellt und Mappe einfach geschlossen.

    Dim WbZ As Workbook
    Dim Pfad$, Dname$, Info

    Pfad = "\\WDMYCLOUD\Team\0 Niko\PLANER\Planer 2020\Backup"
    Dname = "Backup.xlsm"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    With Me
        If Not .ReadOnly Then
            Select Case .Saved
                'Mappe wurde geändert aber NICHT gespeichert
                'Abfrage ob die Original-Mappe überhaupt gespeichert werden soll
                Case Is = False
                    Info = MsgBox("Die Mappe wurde noch nicht gespeichert." & vbLf & _
                        "Soll diese Mappe gespeichert werden?", vbYesNo, _
                        "Schließen und Speichern?")
                    'Wenn Mappe vor dem Schließen gespeichert wird,
                    'dann Sicherheitskopie
                    If Info = vbYes Then
                        .Save
                        .Sheets.Copy
                        Set WbZ = ActiveWorkbook
                        With WbZ
                            .SaveAs Filename:=Pfad & Dname, _
                            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                            .Close True
                        End With
                        .Close
                    'Wenn Mappe vor dem SChließen NICHT gespeichert wird,
                    'dann KEINE Sicherheitskopie
                    Else:
                        .Saved = True
                        .Close
                    End If
                'Mappe wurde NICHT geändert oder bereits gespeichert
                'Dann KEINE Sicherheitskopie
            End Select
        End If
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Speichert eine Sicherheitskopie der Mappe (ohne Makros) bei jedem Speichern
'der Originalmappe, außer bei "Speichern unter..."

    Dim WbZ As Workbook
    Dim Pfad$, Dname$

    Pfad = "\\WDMYCLOUD\Team\0 Niko\PLANER\Planer 2020\Backup"
    Dname = "Backup.xlsm"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    With Me
        If Not .ReadOnly And SaveAsUI = False Then
            .Sheets.Copy
            Set WbZ = ActiveWorkbook
            With WbZ
                .SaveAs Filename:=Pfad & Dname, _
                        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                .Close True
            End With
        End If
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

 

[Nikko]

Hi GWteB,

thx for your message.
Your contribution helps me partly, with the date entry of the file.

But due to my mistake not to send the whole code, I don't get very far. In the end there are error messages

Thanks anyway for your effort and patience

Nikko

 

[Nikko]

upss...Thanks also alpha frog, or better said, especially him

 

[Nikko]

So far so good made a solution for my problem...now if anyone can help need, i would like the date to be automatically written with the saved name.

thx in advance

Option Explicit



Private Const Pfad As String = "\\WDMYCLOUD\Team\0 Niko\PLANER\Planer 2020\Backup\"

Private Const Dname As String = "Backup"



Private Sub Workbook_BeforeClose(Cancel As Boolean)

   

    Dim Info As VbMsgBoxResult

   

    If Not ReadOnly Then

       

        If Not Saved Then

           

           

            If MsgBox("Die Mappe wurde noch nicht gespeichert." & vbLf & _

                "Soll diese Mappe gespeichert werden?", vbYesNo Or vbQuestion, _

                "Schließen und Speichern?") = vbYes Then

               

                With Application

                    .ScreenUpdating = False

                    .DisplayAlerts = False

                    .EnableEvents = False

                End With

               

                Save

               

                Sheets.Copy

                With ActiveWorkbook

                    .SaveAs Filename:=Pfad & Dname, FileFormat:=xlOpenXMLWorkbookMacroEnabled

                    .Close

                End With

               

                With Application

                    .ScreenUpdating = True

                    .DisplayAlerts = True

                    .EnableEvents = True

                End With

               

            Else

               

                Saved = True

               

            End If

        End If

    End If

End Sub



Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

   

   

    If Not ReadOnly And Not SaveAsUI Then

       

        With Application

            .ScreenUpdating = False

            .DisplayAlerts = False

        End With

       

        Sheets.Copy

        With ActiveWorkbook

            .SaveAs Filename:=Pfad & Dname, FileFormat:=xlOpenXMLWorkbookMacroEnabled

            .Close

        End With

       

        With Application

            .ScreenUpdating = True

            .DisplayAlerts = True

        End With

    End If

End Sub

 

[GWteB]

What error messages are you getting?

B.t.w. in post #1 you're declaring "Dname" as a Variable (string), in your code above you're declaring it as a Constant, i.e. a fixed string.
AlphaFrog gave you a solution, based on your 1st post:
Dname = "Backup" & Format(Date, "yyyy-mm-dd") & ".xlsm"

 

[Nikko]

Thx )

now it's complete, it works. Thank you again

 

[GWteB]

You're welcome. Glad it works, thanks for your feedback.