Option Explicit
Sub Разобрать()
CloseEmptyWb
Dim shSource As Worksheet
Set shSource = ActiveSheet
shSource.Copy
Dim shTarget As Worksheet
Set shTarget = ActiveSheet
Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
TargetSheetJob shTarget
Application.Calculation = Application_Calculation
shTarget.Parent.Saved = True
End Sub
Private Sub TargetSheetJob(shTarget As Worksheet)
With shTarget
SplitHeader .Range("B2")
Dim yt As Long, y0 As Long, y3 As Long
For yt = 4 To .UsedRange.Row + .UsedRange.Rows.Count - 1
If .Cells(yt, 3).IndentLevel = 0 Then
y0 = yt
ElseIf .Cells(yt, 3).IndentLevel = 3 Then
y3 = yt
ElseIf .Cells(yt, 3).IndentLevel = 5 Then
.Cells(yt, 2).Cut Destination:=.Cells(yt, 4)
.Cells(y0, 2).Copy .Cells(yt, 2)
.Cells(y3, 2).Copy .Cells(yt, 3)
End If
Next
For yt = .UsedRange.Row + .UsedRange.Rows.Count - 1 To 4 Step -1
If IsEmpty(.Cells(yt, 4)) Then
.Rows(yt).Delete
End If
Next
yt = .UsedRange.Row + .UsedRange.Rows.Count - 1
With .Range("E4:V4").Rows(0)
.FormulaR1C1 = "=SUM(R[1]C:R" & yt & "C)"
.Formula = Application.ConvertFormula(.Formula, xlA1, xlA1, xlRelative)
End With
Dim xs As Long, rs As Range
xs = .UsedRange.Column + .UsedRange.Columns.Count + 1
Set rs = .Range(.Cells(4, xs), .Cells(yt, xs))
Set rs = rs.Resize(, 3)
rs.Columns(1).Formula = "=MATCH(B:B,B:B,0)"
rs.Columns(2).FormulaR1C1 = rs.Columns(1).FormulaR1C1
rs.Columns(3).FormulaR1C1 = rs.Columns(1).FormulaR1C1
With .Sort
.SortFields.Clear
.SortFields.Add Key:=rs.Columns(2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=rs.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rs.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange shTarget.Range(shTarget.Cells(4, 2), shTarget.Cells(yt, xs + 2))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
rs.Clear
End With
End Sub
Private Sub SplitHeader(cl As Range)
Dim arr As Variant
arr = Split(cl.Value, "/")
cl.Cells(1, 2).EntireColumn.Resize(, UBound(arr)).Insert
cl.Resize(1, UBound(arr) + 1).Value = arr
End Sub
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
