Макрос для архивации текущей (или активной) книги Excel средствами Windows
(без использования сторонних программ-архиваторов)
Во вложении - файл, при запуске которого автоматически срабатывает такой макрос
При открытии этого файла, если включены макросы, в папке My Program Backups будет сохранена копия книги в формате ZIP (архив)
Папка, если таковая не существует, будет автоматически создана макросом.
Sub CreateBackup()
' Макрос создания резервной копии текущего файла
' Чтобы макрос обрабатывал активную книгу - замените в коде
' все ThisWorkbook на ActiveWorkbook
' Архивация файла осуществляется средствами Windows
Const PROJECT_NAME = "My Program" ' название вашей программы (любой текст)
On Error Resume Next: ThisWorkbook.Save ' сохраняем книгу Excel
' формируем путь к папке, куда будет помощена копия файла (в виде архива)
BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups\")
MkDir BackupsPath ' создаём папку, если таковой ещё нет
ext$ = Split(ThisWorkbook.Name, ".")(UBound(Split(ThisWorkbook.Name, "."))) ' расширение файла
' формируем путь для копии файла Excel
FileNameXls = BackupsPath & PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & "." & ext$
' формируем путь для создаваемого архива ZIP
FileNameZip = BackupsPath & PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".zip"
ThisWorkbook.SaveCopyAs FileNameXls ' создаём копию книги
ZIPresult = Zip_File(FileNameXls, FileNameZip, True) ' упаковываем копию книги в архив ZIP
Debug.Print "Результат архивации: " & IIf(ZIPresult, "выполнена успешно", "ошибка")
Debug.Print "Создан архив: " & Dir(FileNameZip)
End Sub
