Option Explicit
Private Sub Worksheet_Activate()
Dim Société As SsGroup, Déptmt As SsGroup, CCoût As SsGroup, Détail As Variant, Rés() As Variant, LRés As Long, Lr As Long, C As Long
Dim LDébTotDép As Long, LDébTotCC As Long, Zon As Range, Cel As Range
On Error GoTo Erreur
ReDim Rés(1 To 50000, 1 To [Base].Columns.Count)
For Each Société In GroupOrg([Base], 1, 2, 3)
Lr = Lr + 1: Rés(Lr, 1) = "Société " & Société.Id
For Each Déptmt In Société.Contenu
Lr = Lr + 1: Rés(Lr, 2) = "Département " & Déptmt.Id
LDébTotDép = Lr + 1
For Each CCoût In Déptmt.Contenu
Lr = Lr + 1: Rés(Lr, 3) = "Centre de coût " & CCoût.Id
LDébTotCC = Lr + 1
For Each Détail In CCoût.Contenu
Lr = Lr + 1: For C = 4 To UBound(Rés, 2): Rés(Lr, C) = Détail(C): Next C
Next Détail
Lr = Lr + 1
Rés(Lr, 12) = "Total centre de coût " & CCoût.Id
Rés(Lr, 13) = "=" & LDébTotCC
Next CCoût
Lr = Lr + 1
Rés(Lr, 12) = "Total département " & Déptmt.Id
Rés(Lr, 13) = "=" & LDébTotDép
Next Déptmt
Next Société
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Me.Cells.Delete
Me.[A1].Resize(Lr, UBound(Rés, 2)).Value = Rés
For Each Zon In Me.Columns("M:M").SpecialCells(xlCellTypeFormulas, 1).Areas: For Each Cel In Zon
Cel.Offset(, -1).HorizontalAlignment = xlRight
With Cel.EntireRow.Borders(xlEdgeTop): .LineStyle = xlContinuous: .Weight = xlMedium: End With
Lr = Cel.Value: Cel.Resize(, UBound(Rés, 2) - 13 + 1).FormulaR1C1 = "=SUBTOTAL(9,R" & Lr & "C:OFFSET(RC,-+1,0))"
Next Cel, Zon
Exit Sub
Application.Calculation = xlCalculationAutomatic
Erreur: MsgBox Err.Description: Stop: Resume
End Sub