Главная » Макросы для Excel » Макрос создания копии файла Excel в виде архива ZIP

Макрос создания копии файла Excel в виде архива ZIP

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

Вложения:
AutoBackupWhenOpen.xls39 КБ
  • 33262 просмотра

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".
Игорь (администратор сайта), 25 Авг 2017 - 22:49.#1

Ни разу с таким не сталкивался (не делал многотомные архивы), так что не могу подсказать

Александр, 25 Авг 2017 - 12:26.#2

Подскажите пожалуйста как создать многотомный архив ZIP и задать размер частей.

Гость, 4 Дек 2016 - 21:45.#3

Подскажите пожалуйста а как добавить к имени архива путь исходного файла - это нужно например в том случае если имена документов одинаковые? а расположение разное (с учетом того что архив создается не в текущей папке как в примере, а в одну конкретную папку - например D:\backup). Используя приведенный пример(с изменением папки назначения) невозможно отличить резервную копию файла "отчет1" из папки "декабрь" от "отчет1" из папки "ноябрь"

Максим, 20 Июн 2016 - 20:38.#4

Функция Zip_File ругается если в пути архивируемого файла есть символы «». Есть ли способ обойти это ограничение?

спасибо!

Игорь (администратор сайта), 31 Янв 2016 - 18:11.#5

Дмитрий, да, так и должен делать этот код.
Так устроена работа с ZIP в windows
Для распаковки можно использовать WinRAR - быстрее будет. Примеры кода вроде были у меня на сайте.

Dmitriy, 31 Янв 2016 - 17:08.#6

Подскажите, это только у меня при использовании функции UnZip_File в момент, когда исполняется оператор
oApp.Namespace(DestinationFolder).CopyHere oApp.Namespace(FileNameZip).Items
система автоматически создает в TEMP (c:\Documents and Settings\User\Local Settings\Temp\) папку "Временная папка 1 для имя.zip"
куда параллельно распаковывает архив. Из-за чего извлечение происходит значительно медленнее архивации

Sergey, 4 Июл 2015 - 15:36.#7

При использовании ThisWorkbook.SaveCopyAs FileNameXls
все гиперссылки на папки в сетевом окружении в текущем файле изменяют своё значение с Папка1\Папка2 на ..\Папка1\Папка2
Причем количество "..\" зависит от места копирования, прописанного в FileNameXls (чем глубже папка сохранения относительно текущего файла, тем больше "..\").
Соответственно, все ссылки в текущем файле перестают работать.

Игорь (администратор сайта), 3 Апр 2014 - 16:22.#8

Здравствуйте, Dan.

Программа продолжает работу с оригинальным файлом

Если нужна копия листа - нужен немного другой код:
1) создаете копию 4-го листа методом Copy
например, ThisWorkbook.worksheets(4).copy

2) сохраняете активную книгу (которая создалась при копировании листа) под заданным именем
например: ActiveWorkbook.SaveAs FileNameXls

3) закрываете книгу-бекап без повтороного сохранения:
ActiveWorkbook.Close False

PS: если сами не разберетесь - всегда можно оформить заказ на сайте

Dan, 31 Мар 2014 - 14:58.#9

Подскажите пожлста, у меня 2 вопроса. Первый-с каким файлом будет продолжена работа после сохранения, с тем который забэкапился или с оригиналом? И второй- можно ли как то сохранять не всю книгу, а определенный лист от нее? Например-программа состоит из 4 листов, на 4 листе сводная информация. Нужно чтобы создалась копия файла, только с этим единственным 4 листом.

Игорь (администратор сайта), 11 Мар 2014 - 13:14.#10

Примеры работы с WinRAR есть в комментариях к этой статье,
и здесь ещё: http://excelvba.ru/code/UNZIP

VictorM, 11 Мар 2014 - 12:32.#11

[quote]но код приведён в другой статье.[/quote]
Не подскажете в какой?
Поиском по сайту не могу найти.

Игорь (администратор сайта), 11 Мар 2014 - 04:15.#12

А зачем прописывать в коде какую-то задержку???
Команды ведь последовательно выполняются, - пока архив не создастся, письмо не начнёт формироваться...

И вообще, - в каком формате-то вы архив создаете?
Вы пишете комментарий в статье, где пример кода только для ZIP архивов, - они создаются медленно, средствами Windows.
А изначально вы писали про архив RARб - там совсем другой макрос используется, более надежный и быстрый, - но код приведён в другой статье.

VictorM, 11 Мар 2014 - 01:50.#13

Спасибо за разьяснения.
Тут собственно из папки размером 42мб получается архивный файл 5,6 мб и задержка во времени вот пока эти 5,6 мб пишутся на диск.
У меня сделано сейчас с задержкой времени на 8 сек перед отправкой файла, а на другом компе оказывается этого времени мало, нужно увеличивать.
Вот и думал, может как-то можно этот момент проскочить:).

Игорь (администратор сайта), 11 Мар 2014 - 01:22.#14

Виктор, без файла не получится.
Даже если бы получилось (что невозможно без реализации алгоритма WinRAR в VBA) - к письму-то всё равно прикрепляется именно файл, а не область оперативной памяти...
WinRAR моментально создает архивы (если вы не многомегабайтные файлы формируете), - так что не понимаю, в чем проблема.

VictorM, 11 Мар 2014 - 00:21.#15

Сделал на основе Ваших кодов архивирование и отправку на почту рабочей папки с помощью WinRar.
Все получается, но возник вопрос:
Есть-ли возможность не создавать(не писать на диск) файл .rar, т.е. создавать его в памяти?
Сейчас у меня работает все классически - создается папка, из нее файл архива пишется на диск, затем удаляется исходная папка (командой rar), файл архива отправляется на почту и затем удаляется. Самое ненужное здесь - это запись на файла на диск перед отправкой, да и время занимает, приходится как-то выкручиваться, ждать перед отправкой файла на почту.

Meister Floh, 5 Авг 2013 - 18:55.#16

Если запускать на жестком диске (даже подключенном по USB) - работает. При запуске с флэшки ищет новые тома архива (? :) ) (w7x64 office2k10 x64)

Игорь (администратор сайта), 20 Авг 2012 - 01:22.#17

Здравствуйте, Дмитрий.
Конечно, это возможно.
Оформляйте заказ на сайте, прикрепляйте свой файл с макросом,
подробно опишите, что, куда, под каким именем, и как часто, должно сохраняться.

Для создания архивов RAR нужна программа WinRAR - она у вас установлена?

Дмитрий, 20 Авг 2012 - 00:52.#18

Это конечно все хорошо, у меня такой вопрос, у меня имеется макрос который сохраняет книгу, дубликат, с последующей замены его, и создает дубликат на каждый месяц, суть в чем, мне бы хотелось видоизменить этот макрос, что бы сохранял в архив.rar, возможно ли такое?
С Уважением Дмитрий!

Рудольф, 22 Июн 2011 - 13:12.#19

Спасибо!

Игорь (администратор сайта), 21 Июн 2011 - 13:44.#20

Да, возможно, если использовать программу WinRAR для создания архива.

(как создать запароленный архив средствами Windows - я не знаю)

Читаем справку программы WinRAR - и добавляем ещё один ключ в следующий код: (в строку WinRAR_Keys)

Sub СозданиеSFXархива()
    ' имя создаваемого архива будет иметь вид  [B]Мой архив 17-Feb-2009.exe[/B]
    WinRAR_Path = """C:\Program Files\WinRAR\WinRAR.exe"""
    WinRAR_Keys = " a -r -sfx -ep -agDD-MMM-YYYY "
 
    FolderPath = "C:\Documents and Settings\Игорь\Рабочий стол\" ' папка с файлами
    ArchieveFileName = Chr(34) & FolderPath & "Мой архив .exe" & Chr(34) ' имя и путь создаваемого архива
    Mask = Chr(34) & FolderPath & "*.xls" & Chr(34) ' добавляем только файлы Excel
    Icon = " -iicon" & Chr(34) & "C:\Program Files\Microsoft Office\OFFICE11\MSN.ICO" & Chr(34) ' иконка

    CommandLine = WinRAR_Path & WinRAR_Keys & ArchieveFileName & " " & Mask & Icon
    'MsgBox CommandLine
    Shell CommandLine
End Sub

PS: Убрав в коде ключ -sfx, или заменив его на другой, вы получите архив RAR или ZIP

Рудольф, 21 Июн 2011 - 10:27.#21

А подскажите, возможно ли в таком же плане, но чтоб архив создавался запороленным?

Игорь (администратор сайта), 6 Июн 2011 - 12:25.#22

Посмотрел ещё раз пример из вложения к статье - ничего там не закомментировано, всё работает...

Дмитрий, 25 Май 2011 - 11:24.#23

Все работает, но нужно было раскоментить вторую часть макроса, автор, зачем Вы в примере закоментили Function Zip_File ?

Дмитрий, 25 Май 2011 - 11:09.#24

Добрый день.

У меня при запуске макроса ругается на вот эту строку:

ZIPresult = Zip_File(FileNameXls, FileNameZip, True)

"Sub or function not defined"
если обьявить переменную:
dim Zip_File
то в папке делается копия активной книги, но архив не создается :(
что нужно сделать, чтобы он начал работать?

Игорь (администратор сайта), 19 Апр 2011 - 16:47.#25

Прикрепил файл с примером - то, что вы просили
(автозапуск создания резервной копии книги Excel при открытии файла)

Гость, 19 Апр 2011 - 14:05.#26

a mojno utochnit v kakuiu stroku vstavit, potomu chto prosto v modul vstavil a ona ne deistvuet
???
zaranee spasibo no programma ochen xoroshaia

Игорь (администратор сайта), 16 Апр 2011 - 15:08.#27

Очень просто - достаточно в МОДУЛЬ КНИГИ (модуль ЭтаКнига) добавить такой макрос:

Private Sub Workbook_Open() ' срабатывает каждый раз при открытии файла
    CreateBackup ' архивация книги
End Sub

Сергей, 16 Апр 2011 - 14:02.#28

а как сделать что бы макрос запускался сам без спроса пользователя при открытии файла ?

Игорь (администратор сайта), 5 Мар 2011 - 13:59.#29

русские имена файлов при упаковке превращаются в абракадабру

Странно - у меня всё работает нормально.
Как обойти проблему с кодировками, не знаю, но, может, просто перестать использовать русские символы в имени файлы Excel?
Ведь архив получает корректное имя, а как называется сам файл Excel внутри этого архива, - по сути, не так уж и важно...

Я бы решил проблему так:

' формируем путь для копии файла Excel
    FileNameXls = BackupsPath & "Workbook_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & "." & ext$

VictorM, 5 Мар 2011 - 12:22.#30

Замечательная функция!
До сих пор делал подобное с помощью вызова архиваторов - очень неудобно.
Но только одно здесь у меня не получилось - русские имена файлов при упаковке превращаются в абракадабру.
т.е. сам архив имеет имя
МирУюта_СкладГП_05.03.11_09.09.zip
а внутри архива вот такое
ЊЁа“ов _‘Є« ¤ѓЏ_05.03.11_09.09.xls
Можно это как-то исправить?

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
     _      ____          _          _      ____  
    / \    | ___|   ___  | |        / \    |  _ \ 
   / _ \   |___ \  / __| | |       / _ \   | |_) |
  / ___ \   ___) | \__ \ | |___   / ___ \  |  __/ 
 /_/   \_\ |____/  |___/ |_____| /_/   \_\ |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.