[Toutes versions] Combinaison de plusieurs montants [Résolu]

[LaPanic]

Bonjour tlm,
je cherche a trouver les différentes combinaisons à partir de la somme des chiffres dans la colonne A:A et qui totalisent le nombre 50

A1= 2
A2= 20
A3= 3
A4= 7
A5= 5
A6= 6
A7= 9
A8= 25
A9= 13

le résultat dans la colonne B:B par exemple sera:

B1= 25-20-5
B2= 25-20-3-2
B3= 25-9-6-5-3-2
B4= 25-13-7-5
B5= etc …

Merci pour votre aide

[francky74]

Bonjour,

Ton problème est assez casse tête chinois
As-tu déjà un bout de code ?

pour info, voici ce que j'ai déjà fait pour ton problème. Mais ce n'est pas une solution car je ne prends pas en compte toutes les possibilités !
Il faut encore le modifier mais je te le donne au cas où cela pourrait inspirer quelqu'un !

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Public Sub Addition()
Dim lgLastLig As Long
Dim intResult As Integer, x As Integer, y As Integer, NbreResult As Integer
NbreResult = 0
y = 2
x = 1
 
With Worksheets("Feuil1")                        'à adapter
'Ligne de la dernière cellule remplie de la colonne A
    lgLastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Tri par ordre croissant
 
        For i = lgLastLig To 1 Step -1
            If i = lgLastLig - NbreResult And i <> lgLastLig Then
                i = i - 1
            End If
                intResult = intResult + Cells(i, "A")
                Cells(x, y) = Cells(i, "A")
                If intResult > 50 And lgLastLig > 1 Then
                    intResult = intResult - Cells(i, "A")
                    Cells(x, y) = ""
                    x = x - 1
                End If
                If intResult = 50 Then
                    NbreResult = NbreResult + 1
                    x = 0
                    y = y + 1
                    i = lgLastLig + 1
                    intResult = Cells(lgLastLig - 1, "A")
                End If
                x = x + 1
        Next i
NextSearch:
End With
End Sub

Salut,

J'ai une piste pour ton problème : les suites mathématiques --> n(n+1) / 2
Par contre, fais-tu cette macro toujours avec 9 nombre ou peut-il y en avoir plus ?

[LaPanic]

Merci francky74 pour ta réponse,
oui le nombre des données peut s’élever a beaucoup plus car pour ce cas je cherche a identifier les différentes combinaisons des factures pour les matcher avec un montant de chèque reçu (un chèque pour plusieurs factures).

les suites mathématiques --> n(n+1) / 2 ?
je ne sais pas comment le tester , je sais que le nombre de combinaisons a tester est 9! factoriel pour le cas de 9 factures

Merci pour ton aide !!

[francky74]

Bonjour,

Oui j'ai trouvé un truc qui marche bien avec les suites, mais c'est pas fini !
Essaye déjà ce code en pas à pas et tu verras où j'en suis :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Public Sub Addition()
Dim lgLastLig As Long, lgNbre As Long, lgNbre2 As Long
Dim intResult As Integer, x As Integer, y As Integer, NbreResult As Integer, i As Integer, intNbreVides As Integer
intNbreVides = 0
NbreResult = 0
 
With Worksheets("Feuil1")                        'à adapter
'Ligne de la dernière cellule remplie de la colonne A
    lgLastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Tri par ordre croissant
    n = lgLastLig - 1'nombre de combinaisons par deux
    lgNbre = (n * (n + 1) / 2) - 1
    ReDim Tab1(lgNbre) As String
 
    For x = lgLastLig To 2 Step -1
        For y = x - 1 To 1 Step -1
            NbreResult = Cells(x, "A") + Cells(y, "A")
            Select Case NbreResult
            Case Is < 50
                Tab1(i) = NbreResult & "/" & x & "/" & y
                i = i + 1
            Case Is = 50
            'a coder : on peut écrire le résultat
            Case Is > 50
            'a coder : on met de coté cette solution
            Case Else
 
            End Select
        Next y
    Next x
 
    For i = 0 To lgNbre
        If Tab1(i) = "" Then
        intNbreVides = intNbreVides + 1
            For j = i To lgNbre - 1
                Tab1(j) = Tab1(j + 1)
            Next j
        End If
    Next i
    For i = lgNbre To (lgNbre - intNbreVides + 1) Step -1
        Tab1(i) = ""
    Next i
 
End With
End Sub

Il te faut regarder "Tab1" dans la fenêtre des variables locales. tu verras s'afficher dans cet ordre : résultat "/" première ligne prise en compte dans l'addition "/" deuxième ligne pris en compte dans l'addition. Ce qui donne par exemple 27/3/1 -> la ligne 3 + la ligne 1 = 27. les slashs étant là pour créer une séparation qui sera enlevée à l'inscription du résultat final.

Je ne comprends pas lorsque tu dis que le nombre de combi à tester est 9 !?!
Tu peux donc avoir une liste de 1000 montants mais le nombre de montants à additionner ne dépassera pas 9 ?
Cela veut dire que si, par exemple, tu as 1000 fois 1€, tu n'ariveras jamais à 50€ !?! Ais-je bien compris ???

Salut,

Je continue là où j'en étais :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
Public Sub Addition()
Dim lgLastLig As Long, lgNbre As Long, lgNbre2 As Long
Dim intResult As Integer, x As Integer, y As Integer, NbreResult As Integer, i As Integer, intNbreVides As Integer, intNbreChar As Integer, NbreResult1 As Integer, intResultWrite As Integer
Dim btCmptChar As Byte, btRankChar As Byte
intResultWrite = 1
intNbreVides = 0
NbreResult = 0
intRankTab2 = 0
 
With Worksheets("Feuil1")                        'à adapter
'Ligne de la dernière cellule remplie de la colonne A
    lgLastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    'Tri par ordre croissant
    n = lgLastLig - 1
    lgNbre = (n * (n + 1) / 2) - 1
    ReDim Tab1(lgNbre) As String
 
    For x = lgLastLig To 2 Step -1
        For y = x - 1 To 1 Step -1
            NbreResult = Cells(x, "A") + Cells(y, "A")
            Select Case NbreResult
            Case Is < 50
                Tab1(i) = NbreResult & "/" & x & "/" & y
                i = i + 1
            Case Is = 50
                Cells(intResultWrite, "B") = "Ligne " & x & " Ligne " & y
                intResultWrite = intResultWrite + 1
            Case Is > 50
                Tab1(i) = ">" & NbreResult & "/" & x & "/" & y
                i = i + 1
            Case Else
 
            End Select
        Next y
    Next x
 
    For i = 0 To lgNbre
        If (Tab1(i) = "") Or (Mid(Tab1(i), 1, 1) = ">") Then
        intNbreVides = intNbreVides + 1
            For j = i To lgNbre - 1
                Tab1(j) = Tab1(j + 1)
            Next j
        End If
    Next i
    For i = lgNbre To (lgNbre - intNbreVides + 1) Step -1
        Tab1(i) = ""
    Next i
    lgNbre = lgNbre - intNbreVides
 
    lgNbre2 = (lgNbre + 1) * (lgLastLig - 2)
 
    ReDim Tab2(lgNbre2) As String
 
    intNbreVides = 0
    For i = lgNbre To 0 Step -1
        ReDim intLig(9) As Integer
        btRankChar = 0
    'définition des Nos de lignes déjà utilisées afin de ne pes les recompter dans l'adition.
        intNbreChar = Len(Tab1(i))
        a = 1
        While Mid(Tab1(i), a, 1) <> "/"
            a = a + 1
        Wend
        NbreResult = Mid(Tab1(i), 1, a - 1)
        For a = 1 To intNbreChar
        While Mid(Tab1(i), a, 1) <> "/"
            a = a + 1
        Wend
        c = a + 1
            If Mid(Tab1(i), c, 1) <> "/" Then
                btCmptChar = 1
                While Mid(Tab1(i), c + btCmptChar, 1) <> "/" And Mid(Tab1(i), c + btCmptChar, 1) <> ""
                    btCmptChar = btCmptChar + 1
                Wend
            End If
            intLig(btRankChar) = Mid(Tab1(i), c, btCmptChar)
            btRankChar = btRankChar + 1
            If Mid(Tab1(i), c + 1, 1) <> "" Then
 
            Else
                GoTo Sortie
            End If
 
        Next a
 
Sortie:     'Fin de définition des Nos de lignes déjà utilisées afin de ne pes les recompter dans l'adition.
    For x = lgLastLig To 1 Step -1
        For t = 9 To 0 Step -1
            If intLig(t) = x Then
                GoTo PassLig
            End If
        Next t
 
'comparaison
 
        NbreResult1 = NbreResult + Cells(x, "A")
        Select Case NbreResult1
        Case Is < 50
            Tab2(intRankTab2) = NbreResult1 & "/" & intLig(0) & "/" & intLig(1) & "/" & x
            intRankTab2 = intRankTab2 + 1
        Case Is = 50
                Cells(intResultWrite, "B") = "Ligne " & intLig(0) & " Ligne " & intLig(1) & " Ligne " & x
                intResultWrite = intResultWrite + 1
                intNbreVides = intNbreVides + 1
        Case Is > 50
            Tab2(intRankTab2) = ""
            'intRankTab2 = intRankTab2 + 1
            intNbreVides = intNbreVides + 1
        Case Else
 
        End Select
 
PassLig:
    Next x
 
    Next i
 
 
MsgBox "A suivre  :)"
 
End With
End Sub

C'est assez brouillon dans le code mais ca fonctionne chez moi.

Essaie le chez toi et si ca bloque dis moi où.

Pour l'instant, cette macro ne calcule que trois additions de lignes mais je vais en ajouter.
Il aurait été moins brouillon de faire des boucles mais je ne suis pas très chevronné en VBA donc je fait comme les débutant avancés ... je fait des usines à gaz

[ZebreLoup]

Je me suis bien amusé avec ton problème. Voici un exemple parfait de l'utilisation de la récursivité des fonctions.

Pour utiliser le code suivant, tu rentres la liste des nombres sur la colonne A, le total en B1 et ça te donne les décompositions sur la colonne C.
Ca marche quel que soit le nombre d'éléments sur A.

C'est bien sûr la procédure GetAllDecompo qu'il faut lancer

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Option Explicit
 
Public Sub GetAllDecompo()
    Dim listNumber As New Collection
    Dim total As Integer
    Dim result As Collection
    Dim i, j As Integer
    Dim str As String
 
    Dim ws As Worksheet
    Set ws = Worksheets("Feuil1")
    ws.Range("C:C").ClearContents
 
    'On récupère les paramètres sur la feuille
    i = 1
    While ws.Cells(i, 1) <> ""
        listNumber.Add ws.Cells(i, 1).Value
        i = i + 1
    Wend
    total = ws.Cells(1, 2).Value
 
    'On lance la fonction
    Set result = decompo(listNumber, total)
 
    'On écrit les résultats
    For i = 1 To result.Count
        str = ""
        For j = 1 To result(i).Count
            str = str & result(i)(j) & "+"
        Next j
        str = Left(str, Len(str) - 1)
        ws.Cells(i, 3).Value = str
    Next i
End Sub
 
Private Function decompo(ByVal listN As Collection, ByVal total As Integer) As Collection
    Dim c As New Collection
    Dim cTemp As Collection
    Dim newTotal As Integer
    Dim tmpNb As Integer
    Dim i As Integer
 
    Dim tmpListN As Collection
 
    'S'il n'y a plus qu'un élément, on l'ajoute dans la collection s'il est égal au total
    If listN.Count = 1 Then
        If listN(1) = total Then
            Set cTemp = New Collection
            cTemp.Add total
            c.Add cTemp
        End If
    ElseIf listN.Count > 1 Then
        newTotal = total - listN(1)
        Set tmpListN = getCopy(listN)
        'Sinon, listN ne retrouve pas ses valeurs quand on remonte d'un cran dans la récursivité
        tmpNb = listN(1)
        tmpListN.Remove 1 'On enlève le premier nombre de la liste
 
        'On regarde si on peut faire le total avec les autres
        Set cTemp = decompo(tmpListN, total)
        For i = 1 To cTemp.Count
            c.Add cTemp(i)
        Next i
 
        'Puis on regarde si on peut faire avec les autres le total moins celui là
        If newTotal = 0 Then 'On a notre somme
            Set cTemp = New Collection
            cTemp.Add tmpNb
            c.Add cTemp
        ElseIf newTotal > 0 Then 'On regarde la somme avec le nouveau total
            Set cTemp = decompo(tmpListN, newTotal)
            For i = 1 To cTemp.Count
                cTemp(i).Add tmpNb
                c.Add cTemp(i)
            Next i
        End If
    End If
 
    Set decompo = c
End Function
 
Private Function getCopy(ByVal c As Collection) As Collection
    Dim c2 As New Collection
    Dim i As Integer
    For i = 1 To c.Count
        c2.Add c(i)
    Next i
    Set getCopy = c2
End Function

[francky74]

Salut !
C'est super ton utilisation des collections ! Tu peux y ajouter des éléments sans avoir à déterminer la taille à l'avance comme on le fait avec un tableau (ReDim)



Par contre, j'ai beau faire fonctionner cette macro, je ne vois aucun résultat apparaître dans le fichier Excel !?!

[LaPanic]

Merci pour vos réponses,
le code de ZebreLoup fonctionne parfaitement sauf que je ne sais pas s'il y a une possibilité de l'optimiser car il ne fonctionne pas avec des montants supérieurs à 10000 car j'ai testé avec les chiffres (dans colonne A:A) ci-dessous:

145 023,35
111 541,21
51 658,66
83 045,68
287 850,70
118 568,74
373 910,34
673 326,15
122 747,08
432 520,13
3 410,04

il affiche une erreur:

Erreur d’exécution '6'
Dépassement de capacité

au niveau de la ligne

Code :

newTotal = total - listN(1)

merci pour votre aide

[ZebreLoup]

Non, en fait, je pensais que c'était forcément des entiers. Essaie en remplaçant les Integer par des Double

EDIT :
Nouveau code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
Option Explicit
 
Public Sub GetAllDecompo()
    Dim listNumber As New Collection
    Dim total As Double
    Dim result As Collection
    Dim i, j As Integer
    Dim str As String
 
    Dim ws As Worksheet
    Set ws = Worksheets("Feuil1")
    ws.Range("C:C").ClearContents
 
    'On récupère les paramètres sur la feuille
    i = 1
    While ws.Cells(i, 1) <> ""
        listNumber.Add ws.Cells(i, 1).Value
        i = i + 1
    Wend
    total = ws.Cells(1, 2).Value
 
    'On lance la fonction
    Set result = decompo(listNumber, total)
 
    'On écrit les résultats
    For i = 1 To result.Count
        str = ""
        For j = 1 To result(i).Count
            str = str & result(i)(j) & "+"
        Next j
        str = Left(str, Len(str) - 1)
        ws.Cells(i, 3).Value = str
    Next i
End Sub
 
Private Function decompo(ByVal listN As Collection, ByVal total As Integer) As Collection
    Dim c As New Collection
    Dim cTemp As Collection
    Dim newTotal As Double
    Dim tmpNb As Double
    Dim i As Integer
 
    Dim tmpListN As Collection
 
    'S'il n'y a plus qu'un élément, on l'ajoute dans la collection s'il est égal au total
    If listN.Count = 1 Then
        If listN(1) = total Then
            Set cTemp = New Collection
            cTemp.Add total
            c.Add cTemp
        End If
    ElseIf listN.Count > 1 Then
        newTotal = total - listN(1)
        Set tmpListN = getCopy(listN)
        'Sinon, listN ne retrouve pas ses valeurs quand on remonte d'un cran dans la récursivité
        tmpNb = listN(1)
        tmpListN.Remove 1 'On enlève le premier nombre de la liste
 
        'On regarde si on peut faire le total avec les autres
        Set cTemp = decompo(tmpListN, total)
        For i = 1 To cTemp.Count
            c.Add cTemp(i)
        Next i
 
        'Puis on regarde si on peut faire avec les autres le total moins celui là
        If newTotal = 0 Then 'On a notre somme
            Set cTemp = New Collection
            cTemp.Add tmpNb
            c.Add cTemp
        ElseIf newTotal > 0 Then 'On regarde la somme avec le nouveau total
            Set cTemp = decompo(tmpListN, newTotal)
            For i = 1 To cTemp.Count
                cTemp(i).Add tmpNb
                c.Add cTemp(i)
            Next i
        End If
    End If
 
    Set decompo = c
End Function
 
Private Function getCopy(ByVal c As Collection) As Collection
    Dim c2 As New Collection
    Dim i As Integer
    For i = 1 To c.Count
        c2.Add c(i)
    Next i
    Set getCopy = c2
End Function

[LaPanic]

Merci
non toujours le même problème de dépassement de capacité

[ZebreLoup]

Tu n'as pas changé Integer en Double dans le paramètre de la fonction decompo

[LaPanic]

Merci
ca marche merci il fallait changer integer en double partout
merci