I’ve been tinkering with a routine that uses VBA’s SaveCopyAs function to make a timestamped backup of the active workbook. It lets you choose the location for the backup and sets the name to the workbook’s name followed by a timestamp. I had been using the msoFileDialogSaveAs dialog. However, it shows all the possible file extensions and descriptions which you might save a workbook as.:
And even though the Application.Dialogs object has Delete, Clear and Add functions, those don’t seem to work with the SaveAs and Open dialogsThis doesn’t make sense with SaveCopyAs, which only lets you save to the same file type. Since I want to limit the file extension to the one for the file getting copied, I went with GetSaveAsFilename. It lets you manage the extensions and descriptions that the user sees, for example “Excel Binary Workbook (*.xlsb):
The flip side of GetSaveAsFilename letting you tinker with the file descriptions and extensions is that you have to specify them from scratch. I’d like this routine to be flexible enough to work with all kinds of Excel files and any others you can open in Excel, and I’d like the file descriptions shown by my dialog to match the ones from Save As dialog. So, since msoFileDialogSaveAs contains all the extensions and descriptions you’ll see in a Save As dialog, I wrote a function that searches the msoFileDialogSaveAs.Filters to get the description and extension(s) that go with a particular extension.
Here’s the function:
Dim fdSaveAsFilter(1 To 2) As String
Dim fdFileDialogSaveAs As FileDialog
Dim fdFilter As FileDialogFilter
Dim FilterExtensions As Variant
Dim i As Long
Set fdFileDialogSaveAs = Application.FileDialog(msoFileDialogSaveAs)
For Each fdFilter In fdFileDialogSaveAs.Filters
FilterExtensions = Split(fdFilter.Extensions, ",")
For i = LBound(FilterExtensions) To UBound(FilterExtensions)
If WorksheetFunction.Trim(FilterExtensions(i)) = "*" & FilterExtension Then
fdSaveAsFilter(1) = fdFilter.Description
fdSaveAsFilter(2) = fdFilter.Extensions
GetFdSaveAsFilter = fdSaveAsFilter
GoTo Exit_Point
End If
Next i
Next fdFilter
Exit_Point:
Set fdFileDialogSaveAs = Nothing
End Function
This function is called from my main routine, shown below.
Dim WorkbookToCopy As Excel.Workbook
Dim WorkbookExtension As String
Dim fdSaveAsFilter() As String
Dim WorkbookName As String
If ActiveWorkbook Is Nothing Then
MsgBox "No active workbook."
Exit Sub
End If
If ActiveWorkbook.Path = "" Then
MsgBox "This workbook has never been saved."
Exit Sub
End If
Set WorkbookToCopy = ActiveWorkbook
WorkbookExtension = Mid$(WorkbookToCopy.Name, InStrRev(WorkbookToCopy.Name, "."), 99)
fdSaveAsFilter = GetFdSaveAsFilter(WorkbookExtension)
WorkbookName = Application.GetSaveAsFilename(InitialFileName:=Replace(WorkbookToCopy.FullName, WorkbookExtension, "") & "_" &
'msoFileDialogSaveAs separates extensions with a comma, but GetSaveAsFilename uses a semicolon
GetTimestamp, FileFilter:=fdSaveAsFilter(1) & ", " & Replace(fdSaveAsFilter(2), ",", ";"), Title:="Save Copy As")
If WorkbookName = "False" Then
Exit Sub
End If
WorkbookToCopy.SaveCopyAs WorkbookName
End Sub
GetTimeStamp is a one-line functions that returns a timestamp down to 1/100 of a secon
GetTimestamp = Format(Now(), "yyyymmddhhmmss") & Right(Format(Timer, "#0.00"), 2)
End Function
I thought I’d share my “BackupActiveFile” macro. My requirements are slightly different though: I want to back up the last saved version (i.e. without the changes I’ve made since the last save).
Backups are saved to a subfolder “\Backups”
Dim FS As Object, f As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set f = FS.GetFile(ActiveWorkbook.FullName)
If FS.FolderExists(ActiveWorkbook.Path & "\Backups") = False Then
FS.CreateFolder ActiveWorkbook.Path & "\Backups"
End If
Application.StatusBar = "Backing up " & ActiveWorkbook.Name &"..."
FS.CopyFile _
ActiveWorkbook.FullName, _
ActiveWorkbook.Path & "\_Old_Versions" & _
Replace(ActiveWorkbook.Name, ".xl", "_" & Format(f.DateLastModified, "yyyy-MM-dd_hhmmss") & ".xl")
With Application
.StatusBar = Application.StatusBar & " complete!"
.Wait Now + TimeValue("00:00:01")
.StatusBar = False
End With
Set FS = Nothing
Set f = Nothing
End Sub
Then i have a button to this in the Quick Access Toolbar.
Thanks for sharing. I like the way you deal with keeping the right .xl* extension. Looks like you meant to change “_Old_Versions” to “Backups”. When I do that it works nicely.
Yep you’re right! I use “_Old_Versions” on my machine but figured “Backup” was a better folder name for sharing online, just forgot to change that line.