Const WkName$ = "Feuil1", TitleLine As Boolean = True, TitlesCol% = 1, ValuesCol% = 2, EltMax% = 5, Cible# = 4.5
Dim Tb%(), Cb%(), Cpt&, w(1) As Worksheet, Col%
Sub CmbCdElt()
Dim u%, n#, i%, m&, j&, k%, y#
Application.Calculation = False: Application.ScreenUpdating = False
Call Params: u = UBound(Tb): Cpt = 0
Sheets.Add: Set w(1) = ActiveSheet: Col = 1
For i = 1 To EltMax
ReDim Cb(1 To i)
n = WorksheetFunction.Combin(u + i - 1, i)
For j = 1 To i: Cb(j) = 1: Next j
If Tb(1) = Cible Then Call Writing
For j = 2 To n
Call NextCombin(u)
m = 0
For k = 1 To i: m = m + Tb(Cb(k)): Next k
y = m / i
If y = Cible Then Call Writing
Next j
Next i
If Cpt = 0 Then Application.DisplayAlerts = False: w(1).Delete: Application.DisplayAlerts = True: MsgBox "Aucune combinaison trouvée"
Application.Calculation = True
End Sub
Private Sub NextCombin(ByVal Mx%)
Dim u%, i%, j%
u = UBound(Cb): i = u
Do While Cb(i) = Mx: i = i - 1: Loop
For j = u To i Step -1: Cb(j) = Cb(i) + 1: Next j
End Sub
Private Sub Params()
Dim r&, i&
Set w(0) = Worksheets(WkName): r = w(0).Cells(Rows.Count, 1).End(xlUp).Row: ReDim Tb(1 To r + TitleLine)
For i = 1 To UBound(Tb): Tb(i) = w(0).Cells(i - TitleLine, ValuesCol): Next i
End Sub
Private Sub Writing()
Dim i%, t$
Cpt = Cpt + 1
If Cpt > Rows.Count Then Cpt = 1: Col = Col + 1
For i = 1 To UBound(Cb): t = t & w(0).Cells(Cb(i) - TitleLine, TitlesCol): Next i
w(1).Cells(Cpt, Col) = t
End Sub