Разделение многоуровневного списка по столбцам

6665 08.03.2024 Скачать пример

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

Разделение многоуровневого списка по столбцам

Это могут быть сметы с их бесконечными пунктами-подпунктами работ и материалов, списки задач-подзадач по проектам, бухгалтерские выгрузки статей-подстатей из 1С и т.д. - вариантов миллион. И не знаю, как вам, а мне подобные списки сразу хочется разложить на столбцы по уровням нумерации. Готовых встроенных инструментов в Excel для такого нет, но когда это нас с вами останавливало? :)

Давайте рассмотрим несколько способов реализовать подобную трансформацию в Microsoft Excel.

Способ 1. Формулы

Для начала давайте выясним, на каком уровне (1,2,3...) находится каждый элемент. С ходу видно, что это можно вычислить по количеству точек в нумерации. В подобных случаях, когда вам нужно определить сколько именно раз какой-то символ входит в исходный текст, есть простой рецепт: заменить все интересующие символы (точки в нашем случае) на пустоту (т.е. удалить) и сравнить длину получившегося урезанного текста с длиной исходного. Разница в длине и будет количеством вхождений.

Реализовать эту логику можно следующей формулой:

Формула определения уровня

Здесь функция ПОДСТАВИТЬ (SUBSTITUTE) заменяет точки на пустоту, а функция ДЛСТР (LEN) вычисляет длину текста.

Теперь введём над следующими столбцами цифры уровней 1, 2, 3 и т.д. и добавляем к нашей формуле проверку с извлечением элементов на каждый уровень:

Разбираем на столбцы формулой

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

Ну и, само собой, можно уложить всё это в одну формулу, используя классический принцип построения мегаформул в Excel, когда сначала вся логика расчёта реализуется в отдельных ячейках несколькими простыми формулами, а потом они по очереди копируются и вставляются друг в друга. Т.е. в нашем случае мы прямо в строке формул выделяем и копируем в буфер всё после знака = из ячейки С2 и затем аккуратно вставляем это вместо адреса этой же ячейки $C2 в формулу в ячейку D2 (не забыв добавить доллары где это нужно). Таким образом всё компактно собирается в одну мегаформулу, разобраться в которой, правда, может быть уже сложновато.

Способ 2. Power Query

Иногда подобную задачу бывает проще решить с помощью Power Query - мощной надстройки для импорта и преобразования данных, которая с 2016 версии уже стала неотъемлемой частью Excel.

Для начала давайте конвертируем нашу таблицу в динамическую "умную", используя сочетание клавиш Ctrl+T или команду Главная - Форматировать как таблицу (Home - Format as Table) и загрузим в Power Query - кнопкой Из таблицы/диапазона на вкладке Данные (Data - From table/range).

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

Многоуровневый список загруженный в Power Query

Затем добавим вычисляемый столбец с уровнем для каждого элемента, используя команду Настраиваемый столбец на вкладке Добавление столбца (Add column - Custom column). 

Дальше, в принципе, можно было бы пойти по той же логике, что и в предыдущем способе - удалить все точки из нумерации и посчитать разницу в длине получившегося и исходного текста. Причем можно будет даже не заменять точку на пустоту, как мы это делали ранее функцией ПОДСТАВИТЬ, а удалить напрямую - в языке М, встроенному в Power Query для этого есть прямая функция Text.Remove. Ну, а для вычисления длины текстовой строки подойдет функция Text.Length.

В итоге наша формула могла бы выглядеть так:

Считаем уровень

Если в исходной нумерации где-то случайно вместо точки использовалась, например, запятая или подчеркивание, то можно задать сразу все эти символы как разделители - для этого во втором аргументе функции Text.Remove указывается список в фигурных скобках:

=Text.Length([Номер])-Text.Length(Text.Remove([Номер], {".", ",", "_"}))+1

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

=List.Count(Text.Split([Номер], "."))+1

Если символов-разделителей несколько, то можно использовать функцию Text.SplitAny, вторым аргументом которой и задать все разделители текстовой строкой (уже не используя список):

=List.Count(Text.SplitAny([Номер], ".,_"))+1

После этого останется выделить получившийся столбец с вычисленными уровнями и разложить элементы по значениям из этого столбца на разные колонки. Это легко сделать с помощью команды Преобразование - Столбец сведения (Transform - Pivot column):

Раскладываем по столбцам с помощью Столбец Сведения

В открывшемся окне выбираем столбец данных в качестве результата, а в расширенных параметрах не забываем отключить агрегацию (Don't aggregate) - и задача решена:

Готовый результат в Power Query

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

Минус же в том, что если в столбце с нумерацией вдруг почему-то окажутся дубликаты, то на этих строчках наша процедура сведения даст ошибку. Подстраховаться от такого можно, добавив в наш запрос перед шагом Сведенный столбец (Pivoted column) пару дополнительных шагов, а именно:

  1. Добавить столбец индекса на вкладке Добавление столбца - Столбец индекса (Add column - Index column).
  2. Перенести его за шапку в начало таблицы
После выполнения свёртывания этот вспомогательный индексный столбец можно удалить.

Способ 3. Макрос на VBA

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

Sub Multilevel()

    dim n as Integer, cell as Range

    For Each cell In Selection
        n = UBound(Split(cell, "."))
        If n > 0 Then cell.Offset(0, 1).Resize(1, n).Insert xlShiftToRight
    Next cell

End Sub

Логика тут простая:

  • Проходим в цикле For Each ... Next по выделенным ячейкам (это будут ячейки с нумерацией) и ссылку на очередную ячейку сохраняем в переменную cell.
  • Разделяем полученный номер по точкам на фрагменты с помощью VBA-функции Split и помещаем их в массив.
  • Подсчитываем размер получившегося массива функцией Ubound - это и будет уровень очередного элемента, который кладём в переменную n.
  • Сдвигаемся на ячейку вправо относительно текущей с помощью Offiset(0,1) и выделяем с помощью метода Resize n ячеек.
  • Вставляем n пустых ячеек со сдвигом вправо, отодвигая, таким образом, очередной элемент на его уровень.

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

Минус у такого подхода в том, что после запуска макросов в Excel традиционно, к сожалению, перестаёт работать отмена последнего действия (Undo). Ну, и сохранять наш файл теперь придётся в формате с поддержкой макросов, само собой.

Зато можно добавить этот код в Личную книгу макросов (вашу персональную библиотеку макросов, о которой я уже писал) - и пользоваться им потом многократно, когда это вам потребуется.

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



sweetlanka07@list.ru
14.03.2024 11:42:18
Отличный вариант
Ссылка
Юрий Болоцкий
14.03.2024 12:56:09
Power Query
Подсчитать сколько разделителей через List.Count, добавить перед данными ";" и разделить полученный столбец на части
 #"Добавлен пользовательский объект" = Table.AddColumn(#"Измененный тип", "combine", each Text.Repeat(";",List.Count(Text.SplitAny([Номер],".,_"))-1)&[Данные]),
 #"Разделить столбец по разделителю" = Table.SplitColumn(#"Добавлен пользовательский объект", "combine", Splitter.SplitTextByDelimiter(";", QuoteStyle.Csv), {"combine.1", "combine.2", "combine.3"}),
Ссылка
Serg Num
02.05.2024 09:31:15
Добрый день:)

Я, к сожалению, небольшой спец в Excel, но пытаюсь понять, где можно применить в работах предложенное разнесение по столбцам?

Прошу не винить меня строго ни автора статьи, ни комментаторов.
Ссылка
boeing757
07.05.2024 16:14:27
ok;)
Ссылка
Вячеслав Сысенко
11.05.2024 07:59:50
Извините, но это мухлеж чистой воды. Вы конечно знаете много формул, но в первом столбце сразу произвели разбиение по признаку, а потом как троечник пытаетесь подогнать результат к ответу. Без первого столбца слабо?
Ссылка
Николай Павлов
12.05.2024 17:33:54
Вячеслав, при чем здесь мухлеж и подгон?
Весь смысл этой статьи и видео как раз в том, чтобы имея первый столбец с многоуровневой нумерацией разложить соседний справа столбец на несколько колонок по соответствующим уровням. Без первого столбца это выполнить в принципе невозможно.
Посмотрите еще раз внимательно видео от начала и до конца - должно помочь ;)
Родитель Ссылка
Александр Остапец
25.11.2025 13:05:38
Николай, здравствуйте. большое спасибо за материал!

подскажите, а можно ли в настройку Plex добавить макрос, который будет вытаскивать информацию по автоотступам из выделенного диапазона? писал с помощью ИИ
у меня есть рыба, посмотрите, пожалуйста. таким инструментов пользуюсь часто из-за выгрузок из системы 1С и прочих с портала рабочего.


Sub SmartCopyByIndent()
  Dim cell As Range
  Dim sourceColumn As Long
  Dim ws As Worksheet
  Dim indentLevels As Collection
  Dim uniqueIndents() As Long
  Dim indentMap As Object
  Dim indentLevel As Long
  Dim targetColumn As Long
  Dim i As Long, j As Long
  Dim maxColumns As Long
 
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
 
  On Error GoTo ErrorHandler
  Set ws = ActiveSheet
 
  ' Проверка выделения
  If Selection.Count = 0 Then
      MsgBox "Выделите ячейки для обработки", vbExclamation
      Exit Sub
  End If
 
  ' Проверка что все ячейки в одном столбце
  sourceColumn = Selection.Column
  For Each cell In Selection
      If cell.Column <> sourceColumn Then
          MsgBox "Все выделенные ячейки должны находиться в одном столбце!", vbCritical
          Exit Sub
      End If
  Next cell
 
  ' Собираем уникальные уровни отступов
  Set indentLevels = New Collection
  On Error Resume Next ' Для обработки дубликатов
  For Each cell In Selection
      If Not IsEmpty(cell) Then
          indentLevel = cell.IndentLevel
          indentLevels.Add indentLevel, CStr(indentLevel)
      End If
  Next cell
  On Error GoTo ErrorHandler
 
  ' Если нет отступов - выход
  If indentLevels.Count = 0 Then
      MsgBox "Не найдено ячеек с отступами для обработки", vbInformation
      Exit Sub
  End If
 
  ' Сортируем уровни отступов
  ReDim uniqueIndents(1 To indentLevels.Count)
  For i = 1 To indentLevels.Count
      uniqueIndents(i) = indentLevels(i)
  Next i
 
  ' Простая сортировка пузырьком
  For i = 1 To UBound(uniqueIndents) - 1
      For j = i + 1 To UBound(uniqueIndents)
          If uniqueIndents(i) > uniqueIndents(j) Then
              Dim temp As Long
              temp = uniqueIndents(i)
              uniqueIndents(i) = uniqueIndents(j)
              uniqueIndents(j) = temp
          End If
      Next j
  Next i
 
  ' Создаем сопоставление уровень отступа -> индекс столбца
  Set indentMap = CreateObject("Scripting.Dictionary";)
  For i = 1 To UBound(uniqueIndents)
      indentMap(uniqueIndents(i)) = i - 1 ' Нумерация с 0
  Next i
 
  ' Количество столбцов для вставки = количество уникальных отступов
  maxColumns = indentLevels.Count
 
  ' Добавляем столбцы СПРАВА от исходного
  ws.Columns(sourceColumn + 1).Resize(, maxColumns).Insert _
      Shift:=xlToRight, _
      CopyOrigin:=xlFormatFromLeftOrAbove
 
  ' Заголовки для новых столбцов (без заливки и отступов)
  For i = 0 To maxColumns - 1
      targetColumn = sourceColumn + 1 + i
      ws.Cells(1, targetColumn).Value = "Уровень " & uniqueIndents(i + 1)
      With ws.Cells(1, targetColumn)
          .Font.Bold = True
          .Borders.Weight = xlThin
          .HorizontalAlignment = xlCenter
          .IndentLevel = 0 ' Убираем отступ из заголовка
      End With
  Next i
 
  ' Копируем данные с умным сопоставлением (без отступов в новых ячейках)
  For Each cell In Selection
      If Not IsEmpty(cell) Then
          indentLevel = cell.IndentLevel
          If indentMap.Exists(indentLevel) Then
              targetColumn = sourceColumn + 1 + indentMap(indentLevel)
              ' Копируем значение
              ws.Cells(cell.Row, targetColumn).Value = cell.Value
              ' Убираем отступ из новой ячейки
              ws.Cells(cell.Row, targetColumn).IndentLevel = 0
             
              ' Дополнительно: убираем отступы из пробелов в начале текста
              If Not IsNull(ws.Cells(cell.Row, targetColumn).Value) Then
                  ws.Cells(cell.Row, targetColumn).Value = Trim(ws.Cells(cell.Row, targetColumn).Value)
              End If
          End If
      End If
  Next cell
 
Cleanup:
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
 
  ' Автоподбор ширины
  ws.Columns(sourceColumn + 1).Resize(, maxColumns).AutoFit
 
  ' Формируем детальный отчет
  Dim report As String
  report = "Уникальные уровни отступов:" & vbCrLf
  For i = 1 To UBound(uniqueIndents)
      report = report & "  • Уровень " & uniqueIndents(i) & " → Столбец " & _
               Split(ws.Cells(1, sourceColumn + 1 + i - 1).Address, "$";)(1) & vbCrLf
  Next i
 
  MsgBox "Данные успешно скопированы!" & vbCrLf & _
         "Исходный столбец сохранен без изменений" & vbCrLf & vbCrLf & _
         report & vbCrLf & _
         "Добавлено столбцов: " & maxColumns & vbCrLf & _
         "Во всех новых ячейках удалены отступы", vbInformation
  Exit Sub
 
ErrorHandler:
  MsgBox "Ошибка: " & Err.Description & vbCrLf & _
         "Номер ошибки: " & Err.Number, vbCritical
  Resume Cleanup
End Sub
Родитель Ссылка
Николай Павлов
08.01.2026 13:08:54
Не надо мучить ИИ.
В PLEX давно есть функция IndentLevel как раз для этого случая;)
Родитель Ссылка
Александр Остапец
25.11.2025 13:02:00
Вот макрос, который вытащит информацию с добавлением новых столбцов:


Sub SmartCopyByIndent()
   Dim cell As Range
   Dim sourceColumn As Long
   Dim ws As Worksheet
   Dim indentLevels As Collection
   Dim uniqueIndents() As Long
   Dim indentMap As Object
   Dim indentLevel As Long
   Dim targetColumn As Long
   Dim i As Long, j As Long
   Dim maxColumns As Long
   
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Application.EnableEvents = False
   
   On Error GoTo ErrorHandler
   Set ws = ActiveSheet
   
   ' Проверка выделения
   If Selection.Count = 0 Then
       MsgBox "Выделите ячейки для обработки", vbExclamation
       Exit Sub
   End If
   
   ' Проверка что все ячейки в одном столбце
   sourceColumn = Selection.Column
   For Each cell In Selection
       If cell.Column <> sourceColumn Then
           MsgBox "Все выделенные ячейки должны находиться в одном столбце!", vbCritical
           Exit Sub
       End If
   Next cell
   
   ' Собираем уникальные уровни отступов
   Set indentLevels = New Collection
   On Error Resume Next ' Для обработки дубликатов
   For Each cell In Selection
       If Not IsEmpty(cell) Then
           indentLevel = cell.IndentLevel
           indentLevels.Add indentLevel, CStr(indentLevel)
       End If
   Next cell
   On Error GoTo ErrorHandler
   
   ' Если нет отступов - выход
   If indentLevels.Count = 0 Then
       MsgBox "Не найдено ячеек с отступами для обработки", vbInformation
       Exit Sub
   End If
   
   ' Сортируем уровни отступов
   ReDim uniqueIndents(1 To indentLevels.Count)
   For i = 1 To indentLevels.Count
       uniqueIndents(i) = indentLevels(i)
   Next i
   
   ' Простая сортировка пузырьком
   For i = 1 To UBound(uniqueIndents) - 1
       For j = i + 1 To UBound(uniqueIndents)
           If uniqueIndents(i) > uniqueIndents(j) Then
               Dim temp As Long
               temp = uniqueIndents(i)
               uniqueIndents(i) = uniqueIndents(j)
               uniqueIndents(j) = temp
           End If
       Next j
   Next i
   
   ' Создаем сопоставление уровень отступа -> индекс столбца
   Set indentMap = CreateObject("Scripting.Dictionary";)
   For i = 1 To UBound(uniqueIndents)
       indentMap(uniqueIndents(i)) = i - 1 ' Нумерация с 0
   Next i
   
   ' Количество столбцов для вставки = количество уникальных отступов
   maxColumns = indentLevels.Count
   
   ' Добавляем столбцы СПРАВА от исходного
   ws.Columns(sourceColumn + 1).Resize(, maxColumns).Insert _
       Shift:=xlToRight, _
       CopyOrigin:=xlFormatFromLeftOrAbove
   
   ' Заголовки для новых столбцов (без заливки и отступов)
   For i = 0 To maxColumns - 1
       targetColumn = sourceColumn + 1 + i
       ws.Cells(1, targetColumn).Value = "Уровень " & uniqueIndents(i + 1)
       With ws.Cells(1, targetColumn)
           .Font.Bold = True
           .Borders.Weight = xlThin
           .HorizontalAlignment = xlCenter
           .IndentLevel = 0 ' Убираем отступ из заголовка
       End With
   Next i
   
   ' Копируем данные с умным сопоставлением (без отступов в новых ячейках)
   For Each cell In Selection
       If Not IsEmpty(cell) Then
           indentLevel = cell.IndentLevel
           If indentMap.Exists(indentLevel) Then
               targetColumn = sourceColumn + 1 + indentMap(indentLevel)
               ' Копируем значение
               ws.Cells(cell.Row, targetColumn).Value = cell.Value
               ' Убираем отступ из новой ячейки
               ws.Cells(cell.Row, targetColumn).IndentLevel = 0
               
               ' Дополнительно: убираем отступы из пробелов в начале текста
               If Not IsNull(ws.Cells(cell.Row, targetColumn).Value) Then
                   ws.Cells(cell.Row, targetColumn).Value = Trim(ws.Cells(cell.Row, targetColumn).Value)
               End If
           End If
       End If
   Next cell
   
Cleanup:
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
   Application.EnableEvents = True
   
   ' Автоподбор ширины
   ws.Columns(sourceColumn + 1).Resize(, maxColumns).AutoFit
   
   ' Формируем детальный отчет
   Dim report As String
   report = "Уникальные уровни отступов:" & vbCrLf
   For i = 1 To UBound(uniqueIndents)
       report = report & "  • Уровень " & uniqueIndents(i) & " → Столбец " & _
                Split(ws.Cells(1, sourceColumn + 1 + i - 1).Address, "$";)(1) & vbCrLf
   Next i
   
   MsgBox "Данные успешно скопированы!" & vbCrLf & _
          "Исходный столбец сохранен без изменений" & vbCrLf & vbCrLf & _
          report & vbCrLf & _
          "Добавлено столбцов: " & maxColumns & vbCrLf & _
          "Во всех новых ячейках удалены отступы", vbInformation
   Exit Sub
   
ErrorHandler:
   MsgBox "Ошибка: " & Err.Description & vbCrLf & _
          "Номер ошибки: " & Err.Number, vbCritical
   Resume Cleanup
End Sub
Родитель Ссылка
Наверх