Private Function NextName(sPath$, sWdROOT$, sExp$)  ' вычисление очередного уникального имени файла с корнем sWdROOT в папке sPath
    NextName = False
    On Error GoTo eXXit
    GetAttr (sPath)   ' если папка не существует, то будет ошибка и NextName=False
    Dim i%
    Do
       NextName = sPath & sWdROOT & "(" & i & ")" & sExp
       i = i + 1
    Loop While Dir(NextName) <> ""   ' пока имя не будет уникальным в папке
eXXit:    End Function

Sub Save_Copy_As_I()
'---------------------------------------------------------------------------------------
' Procedure    : Save_Copy_As_I
' Author       : Alex_ST
' Topic_HEADER : Сохранить копию текущего файла, запомнив папку для сохранения
' Topic_URL    : http://www.excelworld.ru/forum/2-1639-18265-16-1335949159
' DateTime     : 02.05.12, 12:59
' Purpose      : Сохранение копии активного файла с автоматическим увеличением суффикса (номера копии)
' Notes        : Путь сохранения копий хранится в коллекции .Names книги (в именованном диапазоне)
'---------------------------------------------------------------------------------------
    Const sPath_in_Names = "Path4SaveCopyAs"   ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла
    Dim sDirPath$, sExp$, sMainName$, FileName, i%
    With ActiveWorkbook
       On Error Resume Next
       sDirPath = .Names(sPath_in_Names).Value   ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names
       If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Path & "\"   ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным ActiveWorkbook.Path
       sDirPath = Mid(sDirPath, 3, Len(sDirPath) - 3)   ' убрать из считанного значения в начале "= и в конце "
       sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\")  ' на всякий случай (если имя было задано в ручную и при этом не верно - без слэша)
       .Names(sPath_in_Names).Value = sDirPath   ' запомнить путь сохранения копий в коллекции .Names под именем sPath_in_Names

       sExp = Right(.Name, Len(.Name) - InStrRev(.Name, ".") + 1)   ' расширение файла вместе с точкой (например, ".xls")
       sMainName = Left(.Name, Len(.Name) - Len(sExp))
       Do
          FileName = sDirPath & sMainName & "(" & i & ")" & sExp: i = i + 1
       Loop While Dir(FileName) <> ""   ' пока имя не будет уникальным в папке
       FileName = Application.GetSaveAsFilename(InitialFileName:=FileName, _
                    FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
                    Title:="Сохранение копии файла")   'задать путь сохранения и имя копии файла в окне выбора
       If VarType(FileName) = vbBoolean Then Exit Sub   ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем
       sDirPath = Left(FileName, InStrRev(FileName, "\"))   ' путь к папке сохранения копий без имени файла
       .Names(sPath_in_Names).Value = sDirPath   ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names
       .SaveCopyAs FileName
    End With
End Sub