Как автоматически разделить таблицу 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, сколько уникальных значений в выбранном Вами столбце. Вся остальная информация автоматически перенесется в новые книги.

Бесплатное обучение Excel

Уровень 1 – Основы Excel
Уровень 2 – Базовые навыки работы в Excel
Уровень 3 – Excel – Продвинутый уровень
Уровень 4 – Профессиональный Excel

Нужна помощь?

Если вам не хочется тратить время на самостоятельную настройку, у нас есть готовые решения — магазин таблиц. А если нужен индивидуальный подход, мы разрабатываем таблицы и системы учёта на заказ под ваши задачи.

Связаться с нами