VBA backup routine (save copy) with Excel 2010

[excelstarter1]

Hey guys,

I coded the following backup routine in VBA last month and just when I needed one of those (presumably working) backup files I noticed the error I made... Stupid rookie mistake I guess.

Basically the code was intended to save a copy of the active workbook with a time/date stamp in a folder called 'Backup'. However, up until now, I did not know, that I cannot force the fileformat when using the command ActiveWorkbook.SaveCopyAs.

I am running Excel 2010, maybe the issue is solved in newer versions of Excel. Anyways, it would be great if a more experienced board user could help me out with this and revise the code. Thinking about it I dont want to force the file format 'xlsx' but instead I just want to keep the original file format (xls, xlsm, csv, ...) and add the time stamp to the original workbook when saving.

Thank you very much in advance!!

Regards

Option Explicit

Sub Create_Backup()

Dim wkbname As String, wkbpath As String, filenm As String

Application.DisplayAlerts = True

wkbname = ActiveWorkbook.Name
wkbpath = ActiveWorkbook.Path
filenm = CreateObject("Scripting.FileSystemObject").GetBaseName(wkbname)

If Dir(wkbpath & "\" & "Backup", vbDirectory) = "" Then 'check if Backup folder already exists, if not > create folder

    If MsgBox("The folder or path " & vbNewLine & vbNewLine & wkbpath & "\" & "Backup" & vbNewLine & vbNewLine & "does not exist." & vbNewLine & vbNewLine & _
         "Want to create the backup folder?", (vbYesNo)) = vbNo Then Exit Sub

        MkDir wkbpath & "\" & "Backup"
        ActiveWorkbook.SaveCopyAs Filename:=wkbpath & "\" & "Backup" & "\" & filenm & "_" & Format(Now, "yyyy-mm-dd_hh-mm") & ".xlsx"

    Else

    ActiveWorkbook.SaveCopyAs Filename:=wkbpath & "\" & "Backup" & "\" & filenm & "_" & Format(Now, "yyyy-mm-dd_hh-mm") & ".xlsx"

End If

CreateObject("WScript.Shell").Popup "Auto backup created", 1, "Backup"
    
End Sub

 

[kelly mort]

Hi,
This thread is concluded with OP - I would suggest that you start your own thread (with link to this one if relevant), you are likely to get more responses.

Dave

Oh okay thanks

 

[ReignEternal]

Hello,

So I have been looking for the same function. I did some testing with the VBA in this and here is what I was able to come up with. Instead of Sub Creeate_Backup( ), I used Private Sub Workbook_Open. I also added a means to check if the With Active workbook statement for the folder path

Private Sub Workbook_Open()

Dim FolderPath As String, FileExt As String
Dim FullFileName As String, msg As String
Dim Response As VbMsgBoxResult
Dim FileName As Variant

With ActiveWorkbook
If .Path = "" Then Exit Sub
FolderPath = ActiveWorkbook.Path & "\Backup"
FileName = Split(ActiveWorkbook.Name, ".")
FileExt = FileName(1)
End With

FullFileName = FolderPath & "\" & _
FileName(0) & "_" & Format(Now, "yyyy-mm-dd_hh-mm-ss") & "." & FileName(1)

msg = "The folder or path " & vbNewLine & vbNewLine & _
FolderPath & vbNewLine & vbNewLine & _
"does not exist." & vbNewLine & vbNewLine & _
"Want to create the backup folder?"


'check if Backup folder already exists
If Dir(FolderPath, vbDirectory) = vbNullString Then
'if not ask user to create folder
Response = MsgBox(msg, 36, "Folder Not Found")
If Response = vbYes Then MkDir FolderPath Else Exit Sub
End If
ActiveWorkbook.SaveCopyAs FileName:=FullFileName
MsgBox "Auto backup created", 48, "Backup"
End Sub

 

[Zubair]

Hi,
I never anticipated such a naming convention

Try this update to code

Sub Create_Backup()
   
    Dim FolderPath As String, FileExt As String
    Dim FullFileName As String, msg As String
    Dim Response As VbMsgBoxResult
    Dim FileName As Variant
   
    With ActiveWorkbook
'folder path
        FolderPath = .Path & "\Backup"
'file ext
        FileExt = Right$(.Name, Len(.Name) - InStrRev(.Name, "."))
'filename no ext
        FileName = Left(.Name, Len(.Name) - Len(FileExt) - 1)
    End With
   
    FullFileName = FolderPath & "\" & _
    FileName & "_" & Format(Now, "yyyy-mm-dd_hh-mm-ss") & "." & FileExt
   
    msg = "The folder or path " & vbNewLine & vbNewLine & _
    FolderPath & vbNewLine & vbNewLine & _
    "does not exist." & vbNewLine & vbNewLine & _
    "Want to create the backup folder?"
   
   
'check if Backup folder already exists
    If Dir(FolderPath, vbDirectory) = vbNullString Then
'if not ask user to create folder
        Response = MsgBox(msg, 36, "Folder Not Found")
        If Response = vbYes Then MkDir FolderPath Else Exit Sub
    End If
   
    ActiveWorkbook.SaveCopyAs FileName:=FullFileName
   
    MsgBox "Auto backup created", 48, "Backup"
End Sub

Dave

Hi Dave I have also benefited from your code thanks.