'### Constante à adapter (nom de la feuille source) ###
Const BASE As String = "Sage"
'######################################################
Sub ApprocheMontant()
Dim S As Worksheet
Dim R As Range
Dim Cible#
Dim g&
Dim i&
Dim j&
Dim k&
Dim var
Dim Total#
Dim T()
Cible# = Sheets(BASE).[g1]
Sheets(BASE).Copy after:=Sheets(1)
Set S = ActiveSheet
S.Rows("1:2").Delete
S.Columns("A:E").Delete
Set R = S.Range(S.Cells(1, 1), S.Cells(S.[a65536].End(xlUp).Row, 1))
R.Sort Key1:=S.[a1], Order1:=xlAscending, Header:=xlNo
var = R
For i& = UBound(var, 1) To 1 Step -1
k& = k& + 1
ReDim Preserve T(1 To 256, 1 To k&)
T(3, k&) = var(i&, 1)
Total# = var(i&, 1)
T(2, k&) = Total#
g& = 3
For j& = i& - 1 To 1 Step -1
If var(i&, 1) > 0 Then
If Total# + var(j&, 1) <= Cible# Then
g& = g& + 1
If g& > 256 Then Exit For
T(g&, k&) = var(j&, 1)
Total# = Total# + var(j&, 1)
T(2, k&) = Total#
End If
End If
Next j&
T(1, k&) = Total# / Cible#
Next i&
S.Cells.Delete
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
R.NumberFormat = "0 000.00"
R.Sort Key1:=S.[a1], Order1:=xlDescending, Header:=xlNo
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), 1))
R.NumberFormat = "0.000%"
With R.Font
.Bold = True
.Color = vbRed
End With
Set R = R.Offset(0, 1)
With R.Font
.Bold = True
.Color = vbBlue
End With
End Sub