Sub JeTeDonne()
Dim ts As ListObject, t, i&, m&
Application.ScreenUpdating = False
Sheets("FEUIL1").Columns("b:c").Insert
Set ts = Sheets("FEUIL1").Range("a1").ListObject
With ts.Range
t = ts.DataBodyRange
For i = 1 To UBound(t): t(i, 2) = i: t(i, 3) = IIf(t(i, 5) < 0, -1, 1): t(i, 5) = Abs(t(i, 5)): Next
ts.DataBodyRange = t
.Sort key1:=.Cells(1, 4), order1:=xlAscending, key2:=.Cells(1, 3), order2:=xlDescending, _
key3:=.Cells(1, 5), order3:=xlAscending, Header:=xlYes, MatchCase:=False
t = ts.DataBodyRange
For i = 1 To UBound(t): t(i, 5) = t(i, 3) * t(i, 5): Next
ts.DataBodyRange = t
For i = UBound(t) To 2 Step -1
If t(i, 5) < 0 Then
For m = i - 1 To 1 Step -1
If t(m, 4) <> t(i, 4) Then Exit For
If t(m, 5) > 0 Then
If Abs(t(i, 5)) <= t(m, 5) Then
t(m, 5) = t(m, 5) + t(i, 5)
t(i, 5) = 0
Else
t(i, 5) = t(i, 5) + t(m, 5)
t(m, 5) = 0
End If
End If
Next m
End If
Next i
ts.DataBodyRange.Value = t
.Sort key1:=.Cells(1, 2), order1:=xlAscending, Header:=xlYes, MatchCase:=False
Sheets("FEUIL1").Columns("b:c").Delete
End With
End Sub