Sub SousTotal2()
Dim a, ncol%, rest(), d As Object, i&, n&, lig&, j%
a = Range("B2:AB" & [A65000].End(xlUp).Row)
ncol = UBound(a, 2)
ReDim rest(1 To UBound(a), 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(a)
If Not d.exists(a(i, 1)) Then _
n = n + 1: d(a(i, 1)) = n: rest(n, 1) = a(i, 1)
lig = d(a(i, 1))
For j = 4 To ncol
rest(lig, j) = rest(lig, j) + a(i, j)
Next
Next
[AD1].Resize(, ncol) = [B1].Resize(, ncol).Value 'en-têtes
[AD2].Resize(n, ncol) = rest
[AD2].Resize(n, ncol).Borders.Weight = xlHairline 'bordures
[AD2].Offset(n).Resize(Rows.Count - n - 1, ncol).Delete xlUp
[AD:AD].Resize(, ncol).Columns.AutoFit
[AE:AF].Delete 'colonnes inutiles
End Sub