Разделение таблицы по листам

В Microsoft Excel есть много инструментов для сборки данных из нескольких таблиц (с разных листов или из разных файлов): прямые ссылки, функция ДВССЫЛ (INDIRECT), надстройки Power Query и Power Pivot и т.д. С этой стороны баррикад всё выглядит неплохо.

Но если вы нарвётесь на обратную задачу - разнесения данных из одной таблицы на разные листы - то всё будет гораздо печальнее. На сегодняшний момент цивилизованных встроенных инструментов для такого разделения данных в арсенале Excel, к сожалению, нет. Так что придется задействовать макрос на Visual Basic, либо воспольоваться связкой макрорекордер+Power Query с небольшой "доработкой напильником" после.

Давайте подробно рассмотрим, как это можно реализовать.

Постановка задачи

Имеем в качестве исходных данных вот такую таблицу размером больше 5000 строк по продажам:

Исходная таблица

Задача: разнести данные из этой таблицы по городам на отдельные листы этой книги. Т.е. на выходе нужно получить на каждом листе только те строки из таблицы, где продажа была в соответствующем городе:

Результаты разнесенные по листам

Подготовка

Чтобы не усложнять код макроса и сделать его максимально простым для понимания, выполним пару подготовительных действий.

Во-первых, создадим отдельную таблицу-справочник, где в единственном столбце будут перечислены все города, для которых нужно создать отдельные листы. Само-собой, в этом справочнике могут быть не все города, присутствующие в исходных данных, а только те, по которым нам нужны отчеты. Проще всего создать такую таблицу, используя команду Данные - Удалить дубликаты (Data - Remove duplicates) для копии столбца Город или функцию УНИК (UNIQUE) - если у вас последняя версия Excel 365.

Поскольку новые листы в Excel по умолчанию создаются перед (левее) текущего (предыдущего), то имеет смысл также отсортировать города в этом справочнике по убыванию (от Я до А) - тогда после создания листы-города расположатся по алфавиту.

Во-вторых, преобразуем обе таблицы в динамические ("умные"), чтобы с ними было проще работать. Используем команду Главная - Форматировать как таблицу (Home - Format as Table) или сочетание клавиш Ctrl+T. На появившейся вкладке Конструктор (Design) назовём их таблПродажи и таблГорода, соответственно:

Таблица продаж и справочник по городам

Способ 1. Макрос для деления по листам

На вкладке Разработчик (Developer) нажмите на кнопку Visual Basic или используйте сочетание клавиш Alt+F11. В открывшемся окне редактора макросов вставьте новый пустой модуль через меню Insert - Module и скопируйте туда следующий код:

Sub Splitter()
    For Each cell In Range("таблГорода")
        Range("таблПродажи").AutoFilter Field:=3, Criteria1:=cell.Value
        Range("таблПродажи[#All]").SpecialCells(xlCellTypeVisible).Copy
        Sheets.Add
        ActiveSheet.Paste
        ActiveSheet.Name = cell.Value
        ActiveSheet.UsedRange.Columns.AutoFit
    Next cell
    Worksheets("Данные").ShowAllData
End Sub	

Здесь с помощью цикла For Each ... Next реализован проход по ячейкам справочника таблГорода, где для каждого города происходит его фильтрация (метод AutoFilter) в исходной таблице продаж и затем копирование результатов на новый созданный лист. Попутно созданный лист переименовывается в то же имя города и на нем включается автоподбор ширины столбцов для красоты.

Запустить созданный макрос в Excel можно на вкладке Разработчик кнопкой Макросы (Developer - Macros) или сочетанием клавиш Alt+F8.

Способ 2. Создаем множественные запросы в Power Query

У предыдущего способа, при всей его компактности и простоте, есть существенный недостаток - созданные макросом листы не обновляются при изменениях в исходной таблице продаж. Если обновление "на лету" необходимо, то придется использовать связку VBA+Power Query, а точнее - создавать с помощью макроса не просто листы со статическими данными, а обновляемые запросы Power Query.

Макрос в этом случае частично похож на предыдущий (в нём тоже есть цикл For Each ... Next для перебора городов в справочнике), но внутри цикла будет уже не фильтрация и копирование, а создание запроса Power Query и выгрузка его результатов на новый лист:

Sub Splitter2()

For Each cell In Range("таблГорода")
    ActiveWorkbook.Queries.Add Name:=cell.Value, Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Источник = Excel.CurrentWorkbook(){[Name=""таблПродажи""]}[Content]," & Chr(13) & "" & Chr(10) & "    #""Измененный тип"" = Table.TransformColumnTypes(Источник,{{""Категория"", type text}, {""Наименование"", type text}, {""Город"", type text}, {""Менеджер"", type text}, {""Дата сделки"", type datetime}, {""Стоимость"", type number}})," & Chr(13) & "" & Chr(10) & "    #""Строки с примененным фильтром"" = Table.Se" & _
        "lectRows(#""Измененный тип"", each ([Город] = """ & cell.Value & """))" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Строки с примененным фильтром"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & cell.Value & ";Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [" & cell.Value & "]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = cell.Value
        .Refresh BackgroundQuery:=False
    End With
    ActiveSheet.Name = cell.Value
Next cell
End Sub

После его запуска мы увидим те же листы по городам, но формировать их будут уже созданные запросы Power Query:

Созданные запросы для каждого города в Power Query

При любых изменениях в исходных данных достаточно будет обновить соответствующую таблицу правой кнопкой мыши - команда Обновить (Refresh) или обновить сразу все города оптом, используя кнопку Обновить всё на вкладке Данные (Data - Refresh All).

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




19.04.2021 17:27:27
Выпала ошибка
"Runtime Error 1004, это имя уже используется, выберите другое"
Все листы появились, но в них остались только заголовки.
25.05.2021 12:20:14
Такая же штука и у меня
20.04.2021 06:20:45
Спасибо Николай! Крутое решение!
Хорошо было бы в надстройку что-то подобное, но более гибкое)
20.04.2021 13:35:09
так в плексе вроде есть такой инструмент
20.04.2021 21:09:52
Спасибо Николай за ваш труд! Всегда с нетерпением жду новых приемов! А можно второй способ добавить в PLEX. Первый способ активно использую, но второй это просто огонь!
26.04.2021 16:11:38
Добрый день, Николай. Наверно, можно добавить и 3й способ: макрос из способа 1, но вместо копирования и вставки части таблицы вставка формулы на базе ФИЛЬТР() в ячейку A1 на каждый лист. Также будет динамическое обновление.
...для такого разделения данных в арсенале Excel, к сожалению, нет.
Есть один. Через сводную таблицу - сводными таблицами (если нужно, то обновляются макросом при активации листа).
Вот в LibreOffice Calc, к сожалению, действительно нет.
Link
04.05.2021 11:16:55
Всем привет!
Помогите пожалуйста макрос запинается на .ListObject.DisplayName = cell.Value
Макрос прописан один в один как у Николая, кроме где PQ выбираем фильтр.
Спасибо большое!
Также - выпала ошибка выпала ошибка
"Runtime Error 1004, это имя уже используется, выберите другое", после нажатие продолжить снова - ошибку показывает на строке:
.ListObject.DisplayName = cell.Value
12.05.2021 13:12:53
Лист с таким именем у вас уже есть, видимо?
При запуске макроса - Листа с таким названием нет, перед запускам удалил все "примеры при записи макроса"
Если ошибку игнорировать и посмотреть в запросы Power Query - там запрос есть, но - сформированной таблицы нет. Возможно ограничения в строчках самой таблице (у меня более 20000 строк и в "справочнике" всего 8 позиций на разделение по листам)?!? Сам макрос идентичен Вашему.
11.06.2021 10:51:18
Здравствуйте. Бьюсь второй день, а "воз и ныне там". Как и у предыдущий комментаторов выходит та-же ошибка "Runtime Error 1004" и  именно здесь ".ListObject.DisplayName = cell.Value" все жёлтое. Как это исправить? Интернет просто накалился от моих поисков исправить ошибку.
11.06.2021 11:26:10
Предполагаю, что у вас уже есть умная таблица с таким именем.
15.06.2021 09:21:54
Спасибо, Николай, за ответ. Изменила название умных таблиц, проблема не ушла.
01.07.2021 20:22:58
Николай, здравствуйте!
Очень плохо еще разбираюсь в макросах, подскажите, пожалуйста, как адаптировать вариант 1 так, чтобы копировалась также ширина столбцов и из диапазонов создавались умные таблицы, все равно с каким именем?

Спасибо!
02.07.2021 00:53:51
Вопрос отпал, решила, что таблица мне не нужна, мне достаточно фильтров. А если делать вторым вариантом, то я и форматирование теряю и все столбцы с шириной поедут.
В итоге совместила свои запросы с еще одной задачей, описанной у вас - на перенос получившихся листов в разные книги и сохранение, и получился вот такой макрос:

Sub Splitter()
   For Each cell In Range("Auditors")
       Range("byVisitsSKU").AutoFilter Field:=1, Criteria1:=cell.Value
       Range("byVisitsSKU[#All]").SpecialCells(xlCellTypeVisible).Copy
       Sheets.Add
       ActiveSheet.Paste
       Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
       SkipBlanks:=False, Transpose:=False
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
       Selection.AutoFilter
       ActiveSheet.Name = cell.Value
       ActiveSheet.UsedRange.Rows.AutoFit
      Next cell
   Worksheets("by Visits_SKU").ShowAllData
   Dim s As Worksheet
   Dim wb As Workbook
   Set wb = ActiveWorkbook
   For Each s In wb.Worksheets
       s.Copy
       ActiveWorkbook.SaveAs "C:\Users\User\Desktop\Nestle Waters\Íîâàÿ ïàïêà" & "\" & s.Name & "_01-09.05.xlsx"
       ActiveWorkbook.Close
       Next
End Sub
09.07.2021 09:14:57
Добрый день!
Спасибо за облегчение труда и автору и участникам!
Скажите пожалуйста, как быть если критериев отбора не 1, а 2 или 3? К примеру и по городам и по датам.
Помогите пожалуйста очень очень нужно.
Спасибо!
Наверх