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

 #"Добавлен пользовательский объект" = Table.AddColumn(#"Измененный тип", "combine", each Text.Repeat(";",List.Count(Text.SplitAny([Номер],".,_"))-1)&[Данные]),
 #"Разделить столбец по разделителю" = Table.SplitColumn(#"Добавлен пользовательский объект", "combine", Splitter.SplitTextByDelimiter(";", QuoteStyle.Csv), {"combine.1", "combine.2", "combine.3"}),

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

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