А вот то же самое, но с автонумерацией вместо проставления времени:
Sub Save_Copy_As_I()
'---------------------------------------------------------------------------------------
' Procedure    : Save_Copy_As_I
' Author       : Alex_ST
' Topic_HEADER : Сохранить копию текущего файла, запомнив папку для сохранения
' Topic_URL    : http://www.excelworld.ru/forum/3-1293-18266-16-1335949341
' DateTime     : 02.05.12, 13:02
' 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

Задавайте вопрос в основном форуме

есть ли возможность добавить сохранение файла в PDF?