Option Explicit
Sub ChercheSomme() ' Ti sur VeriTi
Dim Tableau() As Currency, Plage As Range, Cel As Range
Dim Boucle As Integer, NbSol As Long, K As Integer
Dim TabCombin, Boucle2 As Integer, Montant As Currency
Dim Mini As Integer, Maxi As Integer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
With Feuil1
Set Plage = .Range("BaseDep", .Range("BaseDep").End(xlDown))
Set Cel = .Range("DebSol")
Range(Cel, Cel.End(xlDown)).Resize(, 200).ClearContents
Montant = .Range("Montant") * 1
DetermineMinMax .Range("NbValeurs"), Mini, Maxi, Plage.Rows.Count
End With
ReDim Tableau(1 To Plage.Rows.Count)
For Boucle = 1 To Plage.Rows.Count
Tableau(Boucle) = Plage.Cells(Boucle, 1)
Next Boucle
For K = Mini To Maxi
DoEvents
TabCombin = SommeKSurN(Tableau, K, Montant)
If IsArray(TabCombin) Then
For Boucle = LBound(TabCombin, 2) To UBound(TabCombin, 2)
NbSol = NbSol + 1
Cel = NbSol
For Boucle2 = 1 To K
Cel.Offset(0, Boucle2) = TabCombin(Boucle2, Boucle)
Next Boucle2
Set Cel = Cel.Offset(1, 0)
Next Boucle
End If
Next K
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Cells.Columns.AutoFit
Cells(1, 4).Select
End Sub
Function SommeKSurN(Montant() As Currency, K As Integer, ATrouver As Currency)
Dim Somme As Currency, Resultats() As Currency, N As Integer
Dim Boucle As Integer, NbSol As Long
Dim TabIndex() As Integer
Dim Index As Integer
If Not IsArray(Montant) Then Exit Function
N = UBound(Montant) - LBound(Montant) + 1
If K > N Or ATrouver = 0 Then Exit Function
ReDim TabIndex(1 To K)
For Boucle = 1 To K
TabIndex(Boucle) = Boucle
Next Boucle
Index = K
Do While (Index >= 1) And (TabIndex(K) <= N)
Do While TabIndex(K) <= N
Somme = 0
For Boucle = 1 To K
Somme = Somme + Montant(TabIndex(Boucle))
If Somme > ATrouver Then Exit For
Next Boucle
If Somme = ATrouver Then
NbSol = NbSol + 1
ReDim Preserve Resultats(1 To K, 1 To NbSol)
For Boucle = 1 To K
Resultats(Boucle, NbSol) = Montant(TabIndex(Boucle))
Next Boucle
End If
TabIndex(K) = TabIndex(K) + 1
Loop
Index = K
Do While (Index > 1) And (TabIndex(Index) >= N - K + Index)
Index = Index - 1
Loop
TabIndex(Index) = TabIndex(Index) + 1
For Boucle = Index + 1 To K
TabIndex(Boucle) = TabIndex(Boucle - 1) + 1
Next Boucle
Loop
If NbSol > 0 Then SommeKSurN = Resultats
End Function
Private Sub DetermineMinMax(Valeur As String, Mini As Integer, Maxi As Integer, NbItem As Integer)
Dim Signe As String * 1, Nombre, Boucle As Integer
If Valeur = "" Then
Mini = 1
Maxi = NbItem
Else
Signe = Left(Valeur, 1)
For Boucle = 1 To Len(Valeur)
If IsNumeric(Mid(Valeur, Boucle, 1)) Then _
Nombre = Nombre & Mid(Valeur, Boucle, 1)
Next Boucle
Nombre = Val(Nombre)
Select Case Signe
Case "="
Mini = Nombre
Maxi = Nombre
Case ">"
Mini = Nombre + 1
Maxi = NbItem
Case "<"
Mini = 1
Maxi = Nombre - 1
Case Else
Mini = Nombre
Maxi = Nombre
End Select
End If
End Sub