Save copy automatically as .xlsm

N

Nikko

Board Regular
Joined
Nov 26, 2018
Messages
73
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?

VBA Code: 
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
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
VBA Code: 
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
 
Last edited:
Upvote 0
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
 
Upvote 0
I think I made a mistake when sending the VBA code, I forgot a part. Here is all the code.
VBA 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
 
Upvote 0
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
 
Upvote 0
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 :)

VBA Code: 
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
 
Upvote 0
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"
 
Upvote 0
You're welcome. Glad it works, thanks for your feedback.
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
writing a macro to copy an entire xlsm workbook to a users desktop as xlsx values only.
Replies
9
Views
718
Alex Blakenburg
A
N
  • Question Question
creates a backup file every 4 hours according to computer system time
Replies
2
Views
355
ogalbnafets
O
G
  • Solved
Copy all the data from one specific sheet, paste and save that on a new workbook which as to be save in csv on a specific folder path - VBA
Replies
7
Views
1K
Alex Blakenburg
A
A
  • Question Question
VBA to save file with a different name and / or append suffixes based on conditions
Replies
1
Views
1K
akshay27
A
T
  • Solved
Vba code - Copy, save closed workbook
Replies
4
Views
3K
trevolly
T

Forum statistics

Threads
1,224,826
Messages
6,181,192
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top