Private Sub Сохранить_с_датой ()
' Сохранить файл с датой и временем в имени
Dim Wb As Document
Dim WbName As String
Dim iPath As String
Dim iFileName As String
Dim iFileNameTime As String
Set Wb = ActiveDocument
WbName = Wb.Name
'1. Проверка, что активный файл сохранён на жёстком диске.
' Иначе не известно, по какому пути сохранять.
    If ActiveDocument.path = "" Then
        MsgBox "Активный файл не сохранён на жёстком диске." & Chr(10) & "" & Chr(10) & "Перед сохранением копии сохраните оригинал", vbExclamation
            Exit Sub
'2  Путь к сохраненному документу        
iPath = ActiveDocument.path & "\"
'3 Проверякм существования такого же файла если файл существует добавляем время
If Dir(iPath + iFileName) <> "" Then GoTo iFileName:
iFileNameTime = Left(WbName, Len(WbName) - 5) + "_" + Format(Date, "yy-mm-dd") + " " + Format(Time, "HH-mm") + ".docx"
    Wb.SaveAs (iPath + iFileNameTime)
     End If
    GoTo MyDocTitle
'4. Сохраняем файл с датой сегодняшнего дня
iFileName:
iFileName = Left(WbName, Len(WbName) - 5) + "_" + Format(Date, "yy-mm-dd") + ".docx"
Wb.SaveAs (iPath + iFileName)
' 5. Прописываем в свойствах файла дату и время сохраненки
MyDocTitle:
   '  Call MyDocTitle
End Sub