Sub Save_Copy_As()   
'---------------------------------------------------------------------------------------   
' Procedure    : Save_Copy_As   
' Author       : Alex_ST   
' Topic_HEADER : Как макросом сохранить копию текущего файла?   
' Topic_URL    : http://www.planetaexcel.ru/forum.php?thread_id=16506   
' DateTime     : 08.02.12, 12:00   
' 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