Option Explicit
Sub Essai()
Dim n1&
n1 = Cells(Rows.Count, 2).End(3).Row: If n1 < 3 Then Exit Sub
Dim T, T1&, T2#, T3&, L0&, L1&, L2&, L3&, L4&
Dim n2&, tp As Byte, tm As Byte, ra#, rm&
Application.ScreenUpdating = 0: Range("D2:E" & n1) = Empty
n2 = n1 - 1: T = [A2].Resize(n2, 5): L1 = 1
Do While L1 < n1
T1 = 0: T2 = 0: T3 = 0: tm = 0: rm = 100: L2 = L1
Do While Left$(T(L2, 2), 5) <> "total"
T1 = T1 + T(L2, 3): tp = T(L2, 2)
If tp > tm Then tm = tp: L3 = L2 'taille maxi
L2 = L2 + 1
Loop
For L0 = L1 To L2 - 1
If T1 <> 0 Then
ra = T(L0, 3) / T1 * 100: T(L0, 4) = ra: T2 = T2 + ra
ra = Round(ra, 0): T(L0, 5) = ra: T3 = T3 + ra
If ra < rm Then rm = ra: L4 = L0 'ratio mini
End If
Next L0
Cells(L2 + 1, 3) = T1: T(L2, 4) = T2: T(L2, 5) = T3
If T3 < 100 Then
T(L3, 5) = T(L3, 5) + 1: T(L2, 5) = T3 + 1
ElseIf T3 > 100 Then
T(L4, 5) = T(L4, 5) - 1: T(L2, 5) = T3 - 1
End If
L1 = L2 + 1
Loop
[D2].Resize(19, 2) = Application.Index(T, _
Evaluate("Row(" & "1:" & L2 & ")"), [Column(D:E)])
End Sub