Sub Save_Copy_As()
'---------------------------------------------------------------------------------------
' Procedure    : Save_Copy_As
' Author       : Alex_ST
' DateTime     : 07.02.2012, 17:05
' URL          : http://www.excelworld.ru/forum/3-1293-14737-16-1328619875
' Purpose      : Сохранение копии активного файла
' Notes        : Путь сохранения копий хранится в  коллекции .Names книги (в именованном диапазоне)
'---------------------------------------------------------------------------------------
      Const sPath_in_Names = "Path4SaveCopyAs"   ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла
      Dim sSuff$: sSuff = " [" & Format(Now, "yyyy/mm/dd hh-mm'ss''") & "]"    ' суффикс к имени файла копии - дата и время сохренения копии файла
      Dim FileName, sExp$, sDirPath$, sFullFilePath$, sNewPath$
      Dim bReadOnlyRecommended As Boolean
      With ActiveWorkbook
         FileName = .Name   ' например, "Книга1.xls"
         sExp = Right(FileName, Len(FileName) - InStrRev(FileName, ".") + 1)   ' расширение файла вместе с точкой (например, ".xls")
         FileName = Left(FileName, Len(FileName) - Len(sExp)) & sSuff & sExp   ' например, "Книга1 [2012.02.06 15-24'39''].xls"
         On Error Resume Next
         sDirPath = .Names(sPath_in_Names).Value   ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names
         If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Names(sPath_in_Names).Value   ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным 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
         sFullFilePath = sDirPath & FileName   ' полный путь сохранения вместе с полным именем копии
REPEAT_:
         FileName = Application.GetSaveAsFilename(InitialFileName:=sFullFilePath, _
                      FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
                      Title:="Сохранение копии файла")   'задать путь сохранения и имя копии файла в окне выбора
         If VarType(FileName) = vbBoolean Then Exit Sub   ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем
         If FileName = .FullName Then MsgBox "Здесь нельзя сохранить файл под таким именем!", 16, "Ошибка": GoTo REPEAT_
         sDirPath = Left(FileName, InStrRev(FileName, "\"))   ' путь к папке сохранения копий без имени файла
         .Names(sPath_in_Names).Value = sDirPath   ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names
         bReadOnlyRecommended = .ReadOnlyRecommended   ' запомнить параметры исходного файла
         .ReadOnlyRecommended = --(MsgBox("Рекомендовать открывать файл только для чтения?", 36) - 7)   ' MsgBox Argument 4==vbYesNo 32==vbQuestion, MsgBox Return Values: vbYes=6, vbNo=7
         .SaveCopyAs FileName
         .ReadOnlyRecommended = bReadOnlyRecommended   ' восстановить параметры исходного файла
      End With
End Sub