Сохранение листов книги как отдельных файлов

Про сборку листов из нескольких книг в одну текущую я уже писал здесь. Теперь разберем решение обратной задачи: есть одна книга Excel, которую нужно "разобрать", т.е. сохранить каждый лист как отдельный файл для дальнейшего использования.

save-sheets-as-files.png

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

Если делать эту процедуру вручную, то придется для каждого листа выполнить немаленькую цепочку действий (выбрать лист, правой кнопкой по ярлычку листа, выбрать Копировать, указать отдельный предварительно созданный пустой файл и т.д.) Гораздо проще использовать короткий макрос, автоматизирующий эти действия.

Способ 1. Простое разделение

Нажмите сочетание Alt+F11 или выберите в меню Сервис - Макрос - Редактор Visual Basic (Tools - Macro - Visual Basic Editor), вставьте новый модуль через меню Insert - Module и скопируйте туда текст этого макроса:

Sub SplitSheets1()
    Dim s As Worksheet
    For Each s In ActiveWorkbook.Worksheets    'проходим по всем листам в активной книге
        s.Copy       'копируем каждый лист в новый файл
    Next
End Sub

Если теперь выйти из редактора Visual Basic и вернуться в Excel, а затем запустить наш макрос (Alt+F8), то все листы из текущей книги будут разбиты по отдельным новым созданным книгам.

Способ 2. Разделение с сохранением

При необходимости, можно созданные книги сразу же сохранять под именами листов. Для этого макрос придется немного изменить, добавив команду сохранения в цикл:

Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb as Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                 'проходим во всем листам активной книги
        s.Copy                                                  'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xlsx"  'сохраняем файл
    Next
End Sub

Этот макрос сохраняет новые книги-листы в ту же папку, где лежал исходный файл. При необходимости сохранения в другое место, замените wb.Path на свой путь в кавычках, например "D:\Отчеты\2012" и т.п.

Если нужно сохранять файлы не в стандартном формате книги Excel (xlsx), а в других (xls, xlsm, xlsb, txt и т.д.), то кроме очевидного изменения расширения на нужное, потребуется добавить еще и уточнение формата файла - параметр FileFormat:

ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xlsb", FileFormat:=50  

Для основных типов файлов значения параметра FileFormat следующие:

  • XLSX = 51
  • XLSM = 52
  • XLSB = 50
  • XLS = 56
  • TXT = 42
Полный список всех вариантов можно посмотреть в справке MSDN.

Способ 3. Сохранение в новые книги только выделенных листов

Если вы хотите раскидать по файлам не все листы в вашей книге, а только некоторые, то макрос придется немного изменить. Выделите нужные вам листы в книге, удерживая на клавиатуре клавишу Ctrl или Shift и запустите приведенный ниже макрос:

Sub SplitSheets3()
    Dim AW As Window
    Set AW = ActiveWindow
    For Each s In AW.SelectedSheets
        Set TempWindow = AW.NewWindow    'создаем отдельное временное окно
        s.Copy                           'копируем туда лист из выделенного диапазона
        TempWindow.Close                 'закрываем временное окно
    Next
End Sub

Создавать новое окно и копировать через него, а не напрямую, приходится потому, что Excel не умеет копировать группу листов, если среди них есть листы с умными таблицами. Копирование через новое окно позволяет такую проблему обойти.

Способ 4. Сохранение только выделенных листов в новый файл

Во всех описанных выше способах каждый лист сохранялся в свой отдельный файл. Если же вы хотите сохранить в отдельный новый файл сразу группу выделенных предварительно листов, то нам потребуется слегка видоизменить наш макрос:

Sub SplitSheets4()
    Dim CurW As Window
    Dim TempW As Window
    Set CurW = ActiveWindow
    Set TempW = ActiveWorkbook.NewWindow
    CurW.SelectedSheets.Copy
    TempW.Close
End Sub

Способ 5. Сохранение листов как отдельных PDF-файлов

Этот способ чем-то похож на второй, но листы сохраняются не как отдельные книги Excel, а в формате PDF, что часто требуется, если никто не должен менять документ и увидеть ваши формулы. Обратите внимание, что:
  • для этого используется уже другой метод (ExportAsFixedFormat а не Copy)
  • листы выводятся в PDF с параметрами печати, настроенными на вкладке Разметка страницы (Page Layout)
  • книга должна быть сохранена на момент экспорта

Нужный нам код будет выглядеть следующим образом:

Sub SplitSheets5()
    Dim s As Worksheet

    For Each s In ActiveWorkbook.Worksheets
        s.ExportAsFixedFormat Filename:=ThisWorkbook.Path & "\" & s.Name & ".pdf", Type:=xlTypePDF
    Next
End Sub

Способ 6. Готовый макрос из надстройки PLEX

Если лень или нет времени внедрять все вышеописанное, то можно воспользоваться готовым макросом из моей надстройки PLEX:


Ссылки по теме

 


Страницы: 1  2  
Добрый день.

А можно на примере этого макроса сделать перевод в *pdf одним файлом?


Sub SplitSheets5()
   Dim s As Worksheet

   For Each s In ActiveWorkbook.Worksheets
 s.ExportAsFixedFormat Filename:=ThisWorkbook.Path & "\" & s.Name & ".pdf", Type:=xlTypePDF
   Next
End Sub
28.12.2018 09:37:49
Подскажите, Ругается на строчку s.Copy с ошибкой 1004 (в некоторых ячейках более 255 символов и что часть может быть потеряна), можно как то все равно выполнить скрипт игнорирую ошибку?
28.12.2018 09:49:46
Все, разобрался. Проблема была изза скрытых листов, они по сути не нужны были и ,скорее всего , в них и было много символов в ячейках
24.01.2019 16:57:36
Также столкнулся с такой проблемой, дописал чтобы пропускало скрытые листы:



Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                 'проходим во всем листам активной книги
        If s.Visible = True Then
            s.Copy                                                  'сохраняем лист как новый файл
            ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xlsx"  'сохраняем файл
            ActiveWorkbook.Close False                              'закрываем созданный файл
        End If
    Next
End Sub
03.03.2019 16:50:29
Здравствуйте. А как реализовать в макросе сохранение текущего листа в заранее определённое место, с именем файла как название листа и формате тхт? И чтобы перезаписывал без вопросов если такой уже имеется в папке назначения. Спасибо)
18.05.2019 10:09:21
Здравствуйте, Николай.
1.  При использовании готового макроса из надстройки PLEX "Сохранение листов как файлов"  во вновь созданных файлах слетает галочка с позиции "Точность как на экране" (Задать указанную точность). Поскажите, есть какой-нибудь способ оптом вернуть это свойство в книгу, не меняя в каждом файле индивидуально?
2. В надстройке не сработало заполнение префиксов и суффиксов.  
20.06.2019 10:32:57
Извиняюсь, может не сюда, но мне надо получить из файла с большим кол-вом листов, таблицу из двух колонок:
1. Имя листа;
2. содержимое ячейки A9 каждого листа (это текст, название организации).

Кто может подсказать?
Можно в отдельном файле, можно в том же на новый лист.
или направьте в какой теме спросить...

Спасибо.
19.07.2019 15:22:12
Что-то я сглазил...
В строке:

ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xlsx"  'сохраняем файл
Выскакивает ошибка "Code execution has been interrupted"
Что ей в имени не нравится?!
23.09.2019 16:58:20
Добрый день!

Большое спасибо за тему и множество комментариев.
Не нашёл здесь готового решения для такого случая:
Нужно сохранить 2 конкретных листа с определёнными названиями из книги со множеством листов  в отдельную книгу и задать ей общее имя.
Также формулы на листах нужно заменить на значения с сохранением формата ячеек.

Plex помог не целиком. Да и хотелось бы сделать кнопку на одном из листов, которая бы выполняла эту процедуру.

Буду чертовски  рад комментариям:)
25.09.2019 10:31:04
Добрый день!

Подскажите, пожалуйста, пробовал по 5 способу добавить макрос.
Теперь при каждом открытии любой книги Excel создаются два файла *.pdf и никак не получается это убрать, уже поудалял все макросы.

Заранее спасибо!
04.02.2020 16:13:48
Здравствуйте!
А есть какой-нибудь способ также разделить много книг за один раз?
23.03.2020 15:38:39
Здравствуйте Николай, пытаюсь воспользоваться пятым способом, но вылетает ошибка 1004
Помогите пожалуйта

[img]blob:https://www.planetaexcel.ru/30ffaf5b-798f-455f-9148-9ee727968db3[/img]

[img]blob:https://www.planetaexcel.ru/9389e6b4-bc53-4fc7-8dc8-1f4974f5fc32[/img]

[img]blob:https://www.planetaexcel.ru/d5cb7486-5ba2-4584-a4c1-41aa9a34ca96[/img]
29.04.2020 19:34:20
Здравствуйте, скажите как в примере №3 задать файлам путь для сохранения и что бы они сразу  закрылись как в способе №2
09.05.2020 15:22:54
Скажите пожалуйста, что надо добавить что бы при использовании третьего способа (Сохранение в новые книги только выделенных листов), имя для нового файла было взято из ячейки копируемого листа, допустим А1
1
2
3
4
5
6
7
8
9


Sub SplitSheets3()
   Dim AW As Window
   Set AW = ActiveWindow
   For Each s In AW.SelectedSheets
 Set TempWindow = AW.NewWindow    'создаем отдельное временное окно
 s.Copy   'копируем туда лист из выделенного диапазона
 TempWindow.Close     'закрываем временное окно
   Next
End Sub
12.05.2020 18:06:36
Sub CopyWsh3() 

   ActiveSheet.Copy
   ActiveWorkbook.SaveAs "/Users/sergei/Desktop/" & Range("J4").Value & ".xlsx" 'имя файла берем из ячейки J4


   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
       "/Users/sergei/Desktop/" & Range("J4").Value & ".pdf", Quality:=xlQualityStandard, _
       IncludeDocProperties:=ИСТИНА, IgnorePrintAreas:=ЛОЖЬ, OpenAfterPublish:= _
       ЛОЖЬ
End Sub
 
03.12.2020 10:39:39
Николай, добрый день.
Как мне переделать код, чтобы сохранялись конкретные листы отдельно, а конкретные - одним файлом.
Мне надо, чтобы 1, 2 и 3 лист сохранялись в текущую папку отдельными файлами эксель, а 4, 5, 6 и 7 - в эту же папку одним файлом.
Заранее большое спасибо за ответ, очень поможете....
06.12.2020 06:04:42
Здравствуйте.
А как добавить к
Sub SplitSheets4()    Dim CurW As Window    Dim TempW As Window    Set CurW = ActiveWindow    Set TempW = ActiveWorkbook.NewWindow    CurW.SelectedSheets.Copy    TempW.CloseEnd Sub
взятие названия для файла из ячейки?
21.12.2020 22:40:52
Sub SplitSheets6()
Range("A1:E129").Copy ' Диапазон копирования
myName = Cells(4, 9).Value ' Название файла будем брать из I4


Workbooks.Add ' создаём пустую книгу
ActiveSheet.Paste ' Вставляем ранее выделенный диапазон

' Переводим формулы в значения
   For Each cell In ActiveSheet.UsedRange.Cells
   cell.Formula = cell.Value
   Next cell
   
' Переименовываем получившийся лист
Sheets("Лист1").Name = "Заказ"
' Сохраняем книгу в ..
        ActiveWorkbook.SaveAs "C:\Users\user\Desktop\1" & "\" & myName & ".xlsx", FileFormat:=51
' Закрываем книгу
    ActiveWorkbook.Close
' Конец
End Sub 
Как сделать что-бы формулы в исходной книге оставались, а в сформированной книге заменялись в значения?
     В моём примере если код замены формул вставить высоко, то формулы в обоих книгах заменяются, а если низко, то в результате вместо формул значения "#Н/Д"
09.01.2021 07:40:19
Скорректированный код для случая присвоения имени из ячейки C1:


Sub SplitSheets()
    Dim wb As Workbook
    Dim s As Worksheet
    Dim Path_f, UserName As String
    UserName = Environ("USERNAME")
Application.ScreenUpdating = False: Application.DisplayAlerts = False
'проверка наличия необходимых каталогов (если не создан такой - создаётся)
If Dir("C:\Users\" & UserName & "\Desktop\Narez\", vbDirectory) = "" Then
MkDir "C:\Users\" & UserName & "\Desktop\Narez\"
End If
    Path_f = "C:\Users\" & UserName & "\Desktop\Narez\"
    Set wb = ActiveWorkbook
    On Error Resume Next
    For Each s In wb.Worksheets 'цикл во всем листам активной книги
        If s.Visible = True Then 'игнор скрытых данных
            s.Copy 'копирование данных листа
            'убийство формул
            Cells.Select
            Selection.Copy
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            ActiveWorkbook.SaveAs Path_f & s.Range("C1") 'сохраняем файл с именем из ячейки C1
            ActiveWorkbook.Close False 'закрыть созданную книгу
        End If
    Next
Application.ScreenUpdating = True: Application.DisplayAlerts = True
MsgBox "Файл разрезан на книги.."
End Sub
12.05.2021 14:52:38
Как в 5 способе указать название конкретного листа для сохранения в pdf?
20.09.2021 20:47:25
Приветствую всех!
Помогите пожалуйста, был написан макрос, но к сожалению теперь утерян :


Сохраниение активного листа в новую книгу, в папку где находится исходный файл,   имя файла = название листа
Далее отправка нового файла через Outlook ,   адрес эл.почты из ячейки A1,  тема письма прописана в макросе

Сейчас есть только начало:

Sub SohrList()
Dim CurrentWin As Window
Dim VremWin As Window
Set CurrentWin = ActiveWindow
Set VremWin = ActiveWorkbook.NewWindow
CurrentWin.ActiveSheet.Copy
VremWin.Close
sPath = ThisWorkbook.Path
ThisWorkbook.SaveAs (ThisWorkbook.Path)
End Sub

макрос создает файл с листом, но не берет название и не сохраняет
27.09.2021 20:50:22
Николай, спасибо вам, это решение отлично работает. А есть ли возможность разобрать на отдельные файлы книгу, в которой есть группировка строк на одном листе? Каждую группу в отдельный файл. Нигде не могу найти решения.
29.10.2021 16:18:57
Подскажите, а как сделать так, чтобы в образовавшихся книгах умные таблицы превращались в обычные?
07.12.2021 18:27:56
Подскажите пжл, как можно разбить файлы таким образом чтобы забрать верхние строчки шапки (т.к.в них закреплены значения для расчета)
при попытках разбить Plex формулы во всех разбитых листах едут(
23.11.2022 11:04:06
Здравствуйте! Подскажите пожалуйста, а как изменить эти макросы, чтобы листы не копировались, а перемещались, таким образом в основном файле у меня не будет этих листов, а в новой книге с перемещенными листами сохранятся ссылки на основной файл.
27.12.2022 09:17:56
VBA выдает при использовании любого метода

 Compile error: Syntax error


Раньше все работало.
22.02.2023 12:31:18
Попробовал Вариант 2, но есть значительные недостатки данного макроса:
1. Обновление экрана не отключено, из-за этого процесс по длительности возрастает в разы, но это только начало сказки...
2. При большом объёме листов в книге, все листы, которые разделяются и сохраняются в файлы не закрываются, а накапливаются открытыми, из-за этого процесс EXCEL только наращивает в памяти и в итоге вообще зависает...
3. В шапке макроса отсутствует Msg бокс для запуска макроса, может запуститься и "повесит" всю работу компьютера.
4. После работы макроса не понятно, какой объём работы выполнил макрос?

После всего выше сказанного, прошу рассмотреть данный вариант:

Sub Splitbook()
Dim msg
   msg = MsgBox("Хотите разделить листы книги на отдельные книги excel?", vbYesNo, "Разделение листов по отдельным книгам!"
   If msg = 7 Then Exit Sub

Dim xPath As String, Count As Integer
On Error Resume Next
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ActiveWorkbook.Sheets
If xWs.Visible Then
   xWs.Copy
   Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
   Application.ActiveWorkbook.Close False
   Count = Count + 1
End If
Next xWs
MsgBox "Листы из файла, в количестве " & Count & " шт., разделены!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Страницы: 1  2  
Наверх