vba - workaround for issue excel saving temp files

Question

When saving a specific workbook, Excel creates a temp file instead of saving the data (without displaying an error or warning message). The symptoms are roughly the same as described in this post: microsoft-excel-returns-the-error-document-not-saved-after-generating-a-2gb-temp-file I tried several solutions, but decided to implement a work-around as ‘save as’ is working ok.

The code below performs the ‘save-as’, based on having filenames ending with a value (e.g. myFile V1.xlsm), the macro will add an incremental character (a to z) each time the workbook is saved. (e.g. myFile V1a.xlsm).

The macro works fine in a standard module, but it causes Excel to “stop responding” when moved to ‘thisWorkbook’. I ‘solved’ this by keeping it in the standard module and assigning key combination ‘control-s’ to the macro. Still interested to know if it can be made to work in the ‘thisWorkbook’.

Drawback of this workaround is that each incremental save clogs up the ‘recent file’ list. It would be nice to remove the previous file name from the recent file history, but this seems not possible to do via VBA. (VBA - How do I remove a file from the recent documents list in excel 2007?). Any suggestions?

Windows 10, Excel 2016 (version 16.0.6868.2060)

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

Dim newFilename As String
Dim oldFilename As String

oldFilename = ActiveWorkbook.Name
newFilename = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)

If IsNumeric(Right(newFilename, 1)) = True Then

    ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & "a.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

Else
    If Right(newFilename, 1) = "z" Then
        MsgBox "'z' reached, please save as new version"
        Exit Sub
    End If

    newFilename = Left(newFilename, Len(newFilename) - 1) & Chr(Asc(Right(newFilename, 1)) + 1)
    ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

End If

'potential code to remove oldFilename from 'Recent File' list

End Sub

Answer 1

I tested this Sub in Excel 2010 and it works for me. I immediately break the loop after deleting the file as I assume the indexing may get out of alignment with the loop. A more refined variant might loop through the recent file list and create a collection of indices to delete, then iterate backward over that collection and delete each entry in turn.

Public Sub RemoveRecentFile(strFileName As String)

    Dim collRecentFiles As Excel.RecentFiles
    Dim objRecentFile As Excel.RecentFile
    Dim intRecentFileCount As Integer
    Dim intCounter As Integer

    Set collRecentFiles = Application.RecentFiles
    intRecentFileCount = collRecentFiles.Count

    For intCounter = 1 To intRecentFileCount
        Set objRecentFile = collRecentFiles(intCounter)
        If objRecentFile.Name = strFileName Then
            objRecentFile.Delete
            Exit For
        End If
    Next intCounter

End Sub

Answer 2

Thanks to Robin the working solution is as follows:

Updated intial code:

    Sub incrementSaveAs()
    'to avoid that other workbooks are saved (when assigned to shortkey control-S)
    If ActiveWorkbook.Name <> ThisWorkbook.Name Then ActiveWorkbook.Save: Exit Sub

    Dim newFilename As String
    Dim oldFilename As String

        oldFilename = ActiveWorkbook.Name
        newFilename = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)

        If IsNumeric(Right(newFilename, 1)) = True Then

            ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & "a.xlsm", _
            FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False, AddToMru:=True
            'AddToMru:=True Added to update recent files history

        Else
            If Right(newFilename, 1) = "z" Then
                MsgBox "'z' reached, please save as new version"
                Exit Sub
            End If

            newFilename = Left(newFilename, Len(newFilename) - 1) & Chr(Asc(Right(newFilename, 1)) + 1)
            ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path + "\" + newFilename & ".xlsm", _
            FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False, AddToMru:=True

        End If

        RemoveRecentFile (ActiveWorkbook.Path & Application.PathSeparator & oldFilename)

    End Sub

Updated Robin's code:

Public Sub RemoveRecentFile(strPathAndFileName As String)

    Dim collRecentFiles As Excel.RecentFiles
    Dim objRecentFile As Excel.RecentFile
    Dim intRecentFileCount As Integer
    Dim intCounter As Integer

    Set collRecentFiles = Application.RecentFiles
    intRecentFileCount = collRecentFiles.Count

    For intCounter = 1 To intRecentFileCount
        Set objRecentFile = collRecentFiles(intCounter)
        If objRecentFile.Path = strPathAndFileName Then
            objRecentFile.Delete
            Exit For
        End If
    Next intCounter

End Sub