SaveCopyAs Using GetSaveAsFilename

SaveCopyAs Using GetSaveAsFilename

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.:

Save as xlsb filter

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):

Save copy as 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:

Function GetFdSaveAsFilter(FilterExtension As String) As String()
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.

Sub SaveWorkbookCopy()
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

Function GetTimestamp() As String
GetTimestamp = Format(Now(), "yyyymmddhhmmss") & Right(Format(Timer, "#0.00"), 2)
End Function

3 thoughts on “SaveCopyAs Using GetSaveAsFilename

  1. 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”

     Sub BackupActiveFile()

        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.

  2. 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.

Speak Your Mind

Your email address will not be published. Required fields are marked *

To post code, do this: <code> your vba here </code>