Исправил, но у меня возникает ошибка в строке
ReDim currentHeaderValues(1 To groupLevel)
ReDim currentHeaderValues(1 To groupLevel)
| Код |
|---|
Sub ConvertGroupedDataToTable()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim groupLevel As Integer
Dim outputRow As Long
Dim outputColumn As Integer
Dim headers() As String
Dim headerCount As Integer
Dim currentHeaderValues() As Variant
Dim lastColumn As Integer
' Укажите лист, содержащий сгруппированные данные
Set ws = ThisWorkbook.Sheets("Sheet1") ' Измените "Sheet1" на имя вашего листа
' Определите последнюю строку с данными
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
' Определите максимальный уровень группировки (предполагаем, что он равен кол-ву отступов)
groupLevel = 0
For i = 1 To lastRow
If ws.Cells(i, 1).IndentLevel > groupLevel Then
groupLevel = ws.Cells(i, 1).IndentLevel
End If
Next i
' Инициализация массивов
ReDim headers(1 To groupLevel + 1) ' +1 для колонки с товаром
ReDim currentHeaderValues(1 To groupLevel)
headerCount = groupLevel + 1
' Определите заголовки столбцов (названия уровней группировки)
For j = 1 To groupLevel
headers(j) = j & " группировка"
Next j
headers(groupLevel + 1) = groupLevel + 1 & " группировка"
' Создайте заголовки в новом листе
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Sheets.Add
outputSheet.Name = "Таблица для сводной"
For j = 1 To headerCount
outputSheet.Cells(1, j).Value = headers(j)
Next j
' Инициализируем номер строки для вывода
outputRow = 2
' Пройдитесь по каждой строке исходных данных
Dim currentGroup(1 To 5) As String ' Массив для хранения значений группировок
Dim groupIndex As Integer
For i = 1 To lastRow
' Определите уровень группировки текущей строки
Dim currentLevel As Integer
currentLevel = ws.Cells(i, 1).IndentLevel + 1 ' уровень отступа +1
' Если это не строка с подсуммой/итогом
If Not ws.Cells(i, 1).Font.Bold Then
' Записываем значение в нужную колонку
outputSheet.Cells(outputRow, currentLevel).Value = ws.Cells(i, 1).Value
' Заполняем пустые ячейки справа пробелами
lastColumn = 5 ' Указываем номер последней колонки
For j = currentLevel + 1 To lastColumn
outputSheet.Cells(outputRow, j).Value = ""
Next j
' Если уровень отступа = 0, то это новая строка
If currentLevel = 1 Then
outputRow = outputRow + 1
End If
End If
Next i
MsgBox "Преобразование завершено. Сводная таблица готова на листе '" & outputSheet.Name & "'."
End Sub |
