Sub test()
Dim firstRow As Long, lastRow As Long, lr As Long, CurrentRow As Long, nom As Long
Dim date_, counterparty, store, category, nomenclatureGroup, nomenclature(), count, summ
Dim flag As Boolean, i, level
With Worksheets("tmp")
.Cells.Clear ' очищаем ячейки на листа с именем tmp
End With
nom = 1 ' переменная-счетчик для массива результатов (см. ниже)
With Worksheets("TDSheet") ' имя TDSheet нужно заменить на имя листа с исходной таблицей
firstRow = 14 ' первая ячейка (с датой) ПОМЕНЯТЬ НА НУЖНУЮ
CurrentRow = firstRow ' текущая ячейка (нужна для цикла)
lastRow = .Cells(.Rows.count, 2).End(xlUp).Row ' определяем последнюю заполненную ячейку на листе с данными (TDSheet)
Do While CurrentRow <= lastRow ' пока номер текущей строки меньше номера последней заполненной строки
flag = False ' переменная типа BOOLEAN (для выгрузки результата на лист)
level = .Cells(CurrentRow, 2).EntireRow.OutlineLevel ' определяем уровень группировки в таблице с данными для текущей строки
Select Case level
Case 1 ' если уровень равен 1, то записываем значение строки в переменную date_
date_ = .Cells(CurrentRow, 2).Value
Case 2 ' если уровень равен 2, то записываем данные строки в переменнную counterparty
counterparty = .Cells(CurrentRow, 2).Value
Case 3 ' если уровень равен 3, то записываем данные строки в переменную store
store = .Cells(CurrentRow, 2).Value
End Select
Do While level > 3 ' пока уровень больше 3 (здесь мы записываем в массив все столбцы итоговой таблицы для выгрузки)
flag = True ' означает, что цикл выполнился хотя бы один раз
Select Case level
Case 4 ' если уровень равен 4, то записываем данные строки в переменнную category
category = .Cells(CurrentRow, 2).Value
Case 5 ' если уровень равен 5, то записываем данные строки в переменнную nomenclatureGroup
nomenclatureGroup = .Cells(CurrentRow, 2).Value
Case 6 ' если уровень равен 6, то записываем данные строки в массив (этот массив в последствие будет выгружаться на лист с результатом
ReDim Preserve nomenclature(1 To nom) ' увеличиваем размер массива
nomenclature(nom) = date_ & ":" & counterparty & ":" & _
store & ":" & category & ":" & _
.Cells(CurrentRow, 2).Value & ":" & nomenclatureGroup & ":" & _
.Cells(CurrentRow, 3).Value & ":" & .Cells(CurrentRow, 4).Value
nom = nom + 1 ' увеличиваем счетчик на 1
End Select
CurrentRow = CurrentRow + 1 ' увеличиваем номер строки на 1
level = .Cells(CurrentRow, 2).EntireRow.OutlineLevel ' определяем уровень группировки в таблице с данными для текущей строки
Loop
'===================ВЫГРУЗКА НА ЛИСТ===========================
If flag Then ' если переменная flag == TRUE
With Worksheets("tmp") ' имя tmp нужно заменить на имя листа с результатом
lr = .Cells(.Rows.count, 1).End(xlUp).Row ' определяем последнюю заполненную ячецку на листе с именем tmp
If lr = 1 Then lr = 0 ' если индекс последней заполненной ячейки = 1, то lr = 0
For Each i In nomenclature
.Cells(lr + 1, 1).Resize(1, UBound(Split(i, ":")) + 1) = Split(i, ":") 'выгружаем данные из массива nomenclature на лист с результатом (tmp)
lr = lr + 1 ' увеличиваем номер строки последней заполненной ячейки на 1
Next i
End With
nom = 1
ReDim nomenclature(1 To nom) ' очищаем массив nomenclature
CurrentRow = CurrentRow - 1 ' уменьшаем индекс текущей строки на 1
End If
'===============КОНЕЦ БЛОКА ВЫГРУЗКИ НА ЛИСТ=====================
CurrentRow = CurrentRow + 1 ' увеличиваем индекс текущей строки на 1
Loop
End With
'форматирование на листе с результатом
Call TextToColumns_("tmp") ' имя tmp нужно заменить на имя листа с результатом
End Sub
Private Sub TextToColumns_(shName)
With Worksheets(shName)
.Range("G:G").TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Range("H:H").TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
End With
End Sub |
