Option Explicit
Dim valeurs() As Currency 'reçoit les valeurs de B2:Bx
Dim ptr() As Long 'pointeurs sur les valeurs
Dim somme As Currency ' somme à atteindre
Dim nbTermes As Long 'nombre de termes de la somme
Dim nbSol As Long 'nombre de solutions trouvées
Dim nbMaxSol As Long 'nombre maxi de solutions
Sub RetrouveSomme()
' Retrouve une somme de n termes parmis une liste de x valeurs
'
' Pour des raisons de performance et pour éviter les erreurs d'arrondi
' les valeurs sont converties en format monétaire
' et donc sont arrondis à 4 chiffres après la virgule
'
Dim nbTmin As Long, nbTmax As Long, nbValeurs As Long, nbCombinaison As Double
Dim fini As Boolean, stopper As Boolean, temps As Double, temps2 As Double, temps3 As Double
Dim i As Long, j As Long, k As Long, r As Long, flag2sol As Boolean
'
' nettoyage feuille
[G:IV].EntireColumn.Delete
'
' suppression doublons
If CbxDoublons Then suppDoublons
'
temps = Timer
temps2 = Timer
nbSol = 0
nbValeurs = [B65536].End(xlUp).Row - 1
' contrôle nombre de termes mini
nbTmin = WorksheetFunction.Max(1, [nbTermesmini])
[nbTermesmini] = nbTmin
' contrôle nombre de termes maxi
If [nbTermesMaxi] < 1 Then
nbTmax = nbValeurs
Else
nbTmax = WorksheetFunction.Min([nbTermesMaxi], nbValeurs)
nbTmax = WorksheetFunction.Max([nbTermesmini], nbTmax)
End If
[nbTermesMaxi] = nbTmax
' contrôle nombre max de solutions
If [nbMaxSolutions] <= 240 Then nbMaxSol = [nbMaxSolutions] Else nbMaxSol = 240
If nbMaxSol < 1 Then nbMaxSol = 2
[nbMaxSolutions] = nbMaxSol
' recup valeurs et conversion en currency
ReDim valeurs(nbValeurs)
For i = 1 To nbValeurs
valeurs(i) = CCur(Cells(i + 1, 2))
Next i
somme = CCur([E2])
'
For nbTermes = nbTmin To nbTmax
ReDim ptr(nbTermes)
'init ptr
For i = 1 To nbTermes
ptr(i) = i
Next i
fini = False
Do
nbCombinaison = nbCombinaison + 1
' calcul
calcul
If nbSol = nbMaxSol Then Exit Do
'
' incrémenter pointeurs ptr
ptr(nbTermes) = ptr(nbTermes) + 1 ' incrémenter dernier terme
' 1) prptropager la retenue (vers la gauche)
k = 0
For i = nbTermes To 1 Step -1
' si un terme > nbTmax alors incrémenter terme précédent
If ptr(i) > nbValeurs - nbTermes + i Then
ptr(i - 1) = ptr(i - 1) + 1
' rang le plus bas avec dépassement
k = i
Else
Exit For
End If
Next i
' 2) traiter les dépassements (vers la droite)
If k = 1 Then
' si 1er terme > nbTmax : fini pour ce nombre de termes
fini = True
ElseIf k > 1 Then
' pour chaque terme > nbTmax mettre précedent+1
For j = k To nbTermes
ptr(j) = ptr(j - 1) + 1
Next j
End If
' continuer ?
If nbSol = 2 And Not flag2sol Then
temps3 = Timer
r = MsgBox("2 solutions de trouvées. Continuer ?", vbQuestion + vbYesNo)
temps = temps + Timer - temps3
If r = vbYes Then
temps2 = Timer
flag2sol = True
Else
stopper = True
fini = True
End If
End If
If CbxStop And Timer - temps2 > 180 Then ' 3min
temps3 = Timer
r = MsgBox("5 minutes d'écoulées. Continuer ?", vbQuestion + vbYesNo)
temps = temps + Timer - temps3
If r = vbYes Then
temps2 = Timer
Else
stopper = True
fini = True
End If
End If
Loop While Not fini
If nbSol = nbMaxSol Or stopper Then
Exit For
End If
Next nbTermes
' filtre auto
If nbSol > 0 Then
[A1].Resize(1, nbSol + 6).AutoFilter
End If
'
temps = Timer - temps
If nbSol = nbMaxSol Then
MsgBox ("Nombre maximum de solutions (" & nbMaxSol & ") trouvée(s) en " & Format(temps, "0.00") & " s.")
ElseIf nbSol > 0 Then
MsgBox (nbSol & " solution(s) trouvée(s) en " & Format(temps, "0.00") & " s.")
Else
MsgBox (vbCrLf & "Pas de solution.")
End If
'MsgBox (temps)
End Sub
Sub calcul()
Dim s As Currency, pos As Range, elag As Long
Dim i As Long, j As Long
s = 0: elag = 0
' somme
For i = 1 To nbTermes
s = s + valeurs(ptr(i))
If s > somme And i < nbTermes Then
' élaguer la branche
elag = i
ptr(i) = ptr(i) + 1
' ajuster ptr suivants
For j = i + 1 To nbTermes
ptr(j) = ptr(j - 1) + 1
Next j
ptr(nbTermes) = ptr(nbTermes) - 1
Exit For
End If
Next i
' somme ok ?
If s = somme Then
nbSol = nbSol + 1
'afficher résultat
Set pos = Cells(1, 6 + nbSol)
For i = 1 To nbTermes
pos = "Solution " & nbSol & vbCrLf & "(" & nbTermes & " termes)" & vbCrLf
pos.Offset(ptr(i), 0) = valeurs(ptr(i))
Next i
End If
End Sub
Sub suppDoublons()
Dim lig As Long, r As Long, nbDoub As Long, msg As String
Range([A2], [B65536].End(xlUp)).Font.Bold = False
For lig = [B65536].End(xlUp).Row To 2 Step -1
r = Application.WorksheetFunction.Match(Range("B" & lig), Range("B1", Range("B" & lig)), 0)
If r < lig Then
nbDoub = nbDoub + 1
Range(Range("A" & r), Range("B" & r)).Font.Bold = True
Range(Range("A" & lig), Range("B" & lig)).Delete Shift:=xlUp
End If
Next lig
If nbDoub > 0 Then
msg = nbDoub & " doublon(s) supprimé(s)."
msg = msg & vbCrLf & "Les valeurs qui avaient des doublons sont mises en gras."
MsgBox (msg)
End If
End Sub
