Duplicate File Names

Question

How can I have Excel save a file name with a slight alteration (such as adding "(1)" to the file name) when encountering duplicates using ActiveWorkbook.SaveAs?

Example:

Sub FileSubmission()

    FileN = MbrN & " " & LastN

    FileInfo = "G:\Dir" & FileN

    FileS = Application.GetSaveAsFilename(FileInfo, FileFilter:= _

        "Macro-Enabled Excel Files (*.xlsm),*.xlsm")

    If FileS = "False" Then

        MsgBox "Cancelled"

        GoTo TheEnd

    End If

    ActiveWorkbook.SaveAs Filename:=FileS

TheEnd:

End Sub

The first result I had was a file G:\123456 Jones.xlsm. Ok, fine, that's what I wanted. On the off chance I run this again, and I end up with the same MbrN and LastN variables, I don't want to overwrite the existing file. Rather, I'd like to have a new file saved, such as 123456 Jones(1).xlsm, or 123456 Jones(2).xlsm.

< moved from: Office /Excel/Other/unknown /Office 2013 >

Answer 1

Maybe something like this?

Sub FileSubmission()

    Dim sFileName As String, NewName As String

    Dim fPath As String, fName As String, fExt As String

    Dim i As Integer

    FileN = MbrN & " " & LastN

    FileInfo = "G:\Dir" & FileN

    sFileName = Application.GetSaveAsFilename(FileInfo, FileFilter:= _

        "Macro-Enabled Excel Files (*.xlsm),*.xlsm")

    If sFileName = "False" Then Exit Sub

    If Len(Dir(sFileName)) = 0 Then

        ' file doesn't exist

    Else

        ' Add a number to the filename

        i = 0

        NewName = sFileName

        Do Until Len(Dir(sFileName)) = 0

            i = i + 1

            fPath = Left(NewName, InStrRev(NewName, ""))

            fName = Right(NewName, Len(NewName) - InStrRev(NewName, ""))

            fExt = "." & Right(fName, Len(fName) - InStrRev(fName, "."))

            fName = Left(fName, InStr(fName, ".") - 1) & "(" & i & ")"

            sFileName = fPath & fName & fExt

        Loop

    End If

    ThisWorkbook.SaveAs sFileName

End Sub