Макрос для архивации текущей (или активной) книги 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

Function Zip_File(ByVal FileNameXls, ByVal FileNameZip, _

                  Optional ByVal DeleteSourceFile As Boolean = False) As Boolean

    ' Функция осуществляет упаковку файла FileNameXls в архив с именем FileNameZip

    ' если DeleteSourceFile = TRUE, исходный файл FileNameXls удаляется по окончании архивации

    ' Возвращает TRUE, если архивация завершилось удачно, и FALSE в противном случае

    On Error Resume Next: Err.Clear:

    If Len(Dir(FileNameZip)) > 0 Then Kill FileNameZip

    If Len(Dir(FileNameXls)) = 0 Then MsgBox "Файл """ & FileNameXls & """ не найден!", _

       vbCritical, "Ошибка в функции Zip_File": Exit Function

    Open FileNameZip For Output As #1

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

    Close #1

    Set oApp = CreateObject("Shell.Application")

    oApp.Namespace(FileNameZip).CopyHere FileNameXls    'копируем файл в сжатую папку

    Do Until oApp.Namespace(FileNameZip).Items.Count = 1    'ждём завершения упаковки файла

        Application.Wait (Now + TimeValue("0:00:01"))

    Loop

    If DeleteSourceFile Then Kill FileNameXls    ' удаляем временно созданный файл

    Zip_File = Err = 0    ' возвращаем результат упаковки (TRUE, если всё завершилось удачно)

End Function

Функция для разархивирования (извлечения файлов из архива ZIP)

Function UnZip_File(ByVal FileNameZip, ByVal DestinationFolder, _

                    Optional ByVal DeleteSourceFile As Boolean = False) As Boolean

    ' Функция осуществляет распаковку архива с именем FileNameZip в папку DestinationFolder

    ' если DeleteSourceFile = TRUE, исходный файл FileNameZip удаляется по окончании архивации

    ' Возвращает TRUE, если файлы извлечены удачно, и FALSE в противном случае

    On Error Resume Next: Err.Clear

    If Right(DestinationFolder, 1) <> "\" Then DestinationFolder = DestinationFolder & "\"

    MkDir DestinationFolder    ' создаём папку, если таковой ещё нет

    If Len(Dir(DestinationFolder, vbDirectory)) = 0 Then Exit Function    ' не удалось создать папку

    If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _

       vbCritical, "Ошибка в функции UnZip_File": Exit Function

    Set oApp = CreateObject("Shell.Application")

    For Each it In oApp.Namespace(FileNameZip).Items: Debug.Print it: Next

    oApp.Namespace(DestinationFolder).CopyHere oApp.Namespace(FileNameZip).Items    'распаковываем файлы

    If DeleteSourceFile Then Kill FileNameZip    ' удаляем исходный архив

    UnZip_File = Err = 0    ' возвращаем результат распаковки (TRUE, если всё завершилось удачно)

End Function