Как автоматически разделить таблицу Excel на несколько книг
Введение
Предположим, у нас есть рабочий лист с большим количеством данных, и нам нужно разделить данные на отдельные книги Excel на основе столбца «Категория». Решить данную проблему возможно ручным способом, применяя инструмент фильтрации данных. Однако повторное копирование данных потребует терпения.
Как быстро разделить таблицу Excel на отдельные книги макросом. Пошаговый алгоритм
- Сочетанием клавиш Alt+F11 открываем окно Visual Basic
- Создаем новый модуль Insert -> Module
- Вставляем код
Sub Разделить_столбец_по_книгам()
Const column = 2 'номер столбца, по которому будет происходить разделение.'
Const head = True
Set wbAct = ActiveWorkbook
Set dic = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).column
arr = Range("A1", Cells(lr, lc)).Value
If head Then fr = 2 Else fr = 1
For i = fr To UBound(arr)
If Trim(arr(i, column)) <> "" Then dic.Item(arr(i, column)) = dic.Item(arr(i, column)) & "|" & i
Next
iPath = wbAct.Path & Application.PathSeparator & "Result" & Application.PathSeparator
'Result - название папки с результатами'
If Dir(iPath, vbDirectory) = "" Then MkDir iPath
arrDic = dic.keys
Set Rng = Nothing
Application.DisplayAlerts = False
For i = 0 To UBound(arrDic)
rrs = Split(Mid(dic.Item(arrDic(i)), 2), "|")
If head Then Set Rng = Rows(1)
For Each rr In rrs
If Not Rng Is Nothing Then Set Rng = Union(Rows(rr), Rng) Else Set Rng = Rows(rr)
Next
Set wb = Workbooks.Add(1)
Set sh = wb.Sheets(1)
Rng.Copy
sh.[A1].PasteSpecial xlPasteColumnWidths
sh.[A1].PasteSpecial xlPasteAll
Set Rng = Nothing
wb.SaveAs iPath & Replace_symbols(arrDic(i)) & ".xlsx", xlOpenXMLWorkbook
wb.Close False
Next
Application.DisplayAlerts = True
End Sub
'Замена запрещённых символов в имени файла или папки'
Function Replace_symbols(ByVal txt As String) As String
St$ = "\\/~!@#$%^&*=|`'"""
For i% = 1 To Len(St$)
txt = Replace(txt, Mid(St$, i, 1), "_")
Next
Replace_symbols = txt
End Function- На второй строке кода, цифру 2 замените на номер столбца, в котором содержится критерий для разбиения
- Сохраните код Ctrl+S
- Сохраните файл Excel, как книгу с поддержкой макросов xlsm
- Выполните макрос Alt+F8
Папка с новыми файлами будет лежать по тому же пути, что и файл, в котором вы запускали макрос
Заключение
С помощью этого руководства и готового кода макроса Вы сможете сэкономить свое время и за несколько минут создать столько книг Excel, сколько уникальных значений в выбранном Вами столбце. Вся остальная информация автоматически перенесется в новые книги.