Microsoft 365 trouver les éléments d'une somme en vba

[SteVh]

bonjours chers tous,
je souhaiterais avoir une code VBA qui trouveras l'ensemble des nombres d'une somme:
l'outil SOLVER à un nombre limité de données à traiter

			MT rechercher
Date opé / Cptable	Crédit	resultat	86 356
28/05/2019​	10 107	A
28/05/2019​	36 621	A
28/05/2019​	39 625	A
30/05/2019​	18 187
30/05/2019​	25 546
03/06/2019​	8 638
05/06/2019​	18 034
06/06/2019​	14 882
06/06/2019​	21 493

 

[sylvanu]

Bonjour SteVh,
86356 n'est pas la somme des trois premiers, ça fait 86353.
j'espère que le piège n'était pas volontaire.

Une solution possible en PJ. La limitation est de 16 valeurs, avec :

Sub Calcul()
    DL = Range("B65500").End(xlUp).Row
    Range("C4:C" & DL).ClearContents
    T = Range("B4:B" & DL)
    S = [D3]: Tmax = UBound(T)
    ReDim T2(2 ^ Tmax, Tmax)
    For i = 0 To 2 ^ Tmax
        Nbin = DecBin(i)
        For j = 0 To Tmax
            Valbit = Mid(Nbin, Len(Nbin) - j, 1)
            If Valbit = "1" Then
                On Error Resume Next
                T2(i, j) = T(j + 1, 1)
            Else
                T2(i, j) = 0
            End If
        Next j
    Next i
    For i = 0 To UBound(T2)
        somme = 0
        For j = 0 To Tmax
            somme = somme + T2(i, j)
        Next j
        If somme = S Then Exit For
    Next i
    If somme = 0 Then
        MsgBox "Pas de solution trouvée."
    Else
        For k = 0 To Tmax
            If T2(i, k) <> 0 Then Range("C" & k + 4) = "A"
        Next k
    End If
End Sub
Function DecBin(ByVal N As Long) As String
    Dim C$
    Do While N > 1
        C = N - 2 * (N \ 2) & C
        N = N \ 2
    Loop
    DecBin = Right("0000000000000000" & N & C, 16)
End Function

 

[SteVh]

Bonjour SteVh,
86356 n'est pas la somme des trois premiers, ça fait 86353.
j'espère que le piège n'était pas volontaire.

Une solution possible en PJ. La limitation est de 16 valeurs, avec :

Sub Calcul()
    DL = Range("B65500").End(xlUp).Row
    Range("C4:C" & DL).ClearContents
    T = Range("B4:B" & DL)
    S = [D3]: Tmax = UBound(T)
    ReDim T2(2 ^ Tmax, Tmax)
    For i = 0 To 2 ^ Tmax
        Nbin = DecBin(i)
        For j = 0 To Tmax
            Valbit = Mid(Nbin, Len(Nbin) - j, 1)
            If Valbit = "1" Then
                On Error Resume Next
                T2(i, j) = T(j + 1, 1)
            Else
                T2(i, j) = 0
            End If
        Next j
    Next i
    For i = 0 To UBound(T2)
        somme = 0
        For j = 0 To Tmax
            somme = somme + T2(i, j)
        Next j
        If somme = S Then Exit For
    Next i
    If somme = 0 Then
        MsgBox "Pas de solution trouvée."
    Else
        For k = 0 To Tmax
            If T2(i, k) <> 0 Then Range("C" & k + 4) = "A"
        Next k
    End If
End Sub
Function DecBin(ByVal N As Long) As String
    Dim C$
    Do While N > 1
        C = N - 2 * (N \ 2) & C
        N = N \ 2
    Loop
    DecBin = Right("0000000000000000" & N & C, 16)
End Function

infiniment merci , mais je crois qu'il y a un blocage au niveau des par-feux qui bloquent la macro

 

[sylvanu]

Bonjour,
Il vous faut activer les macros avec Options Excel/Centre de gestion/Parametres de centre de gestion/Paramètres des macros cochez Activer toutes les macros/

 

[SteVh]

i

Bonjour SteVh,
86356 n'est pas la somme des trois premiers, ça fait 86353.
j'espère que le piège n'était pas volontaire.

Une solution possible en PJ. La limitation est de 16 valeurs, avec :

Sub Calcul()
    DL = Range("B65500").End(xlUp).Row
    Range("C4:C" & DL).ClearContents
    T = Range("B4:B" & DL)
    S = [D3]: Tmax = UBound(T)
    ReDim T2(2 ^ Tmax, Tmax)
    For i = 0 To 2 ^ Tmax
        Nbin = DecBin(i)
        For j = 0 To Tmax
            Valbit = Mid(Nbin, Len(Nbin) - j, 1)
            If Valbit = "1" Then
                On Error Resume Next
                T2(i, j) = T(j + 1, 1)
            Else
                T2(i, j) = 0
            End If
        Next j
    Next i
    For i = 0 To UBound(T2)
        somme = 0
        For j = 0 To Tmax
            somme = somme + T2(i, j)
        Next j
        If somme = S Then Exit For
    Next i
    If somme = 0 Then
        MsgBox "Pas de solution trouvée."
    Else
        For k = 0 To Tmax
            If T2(i, k) <> 0 Then Range("C" & k + 4) = "A"
        Next k
    End If
End Sub
Function DecBin(ByVal N As Long) As String
    Dim C$
    Do While N > 1
        C = N - 2 * (N \ 2) & C
        N = N \ 2
    Loop
    DecBin = Right("0000000000000000" & N & C, 16)
End Function

intiment merci! elle fonctionne bien.
toute fois , serait il possible d’étendre sa limitation à 50

 

[sylvanu]

Bonjour,
Non, avec 50 je ne sais pas faire avec la structure choisie.
De tout façon le temps de calcul deviendrait prohibitif vu le nombre de combinaisons à tester.
Mais ça veut dire qu'un client pourrait avoir 50 factures en souffrance qu'il réglerait d'un seul coup ?
Si c'est le cas je ne vois pas de solution pour ma part.

 

[sylvanu]

Re,
Avec 50 factures le nombre de combinaisons serait de 1125899906842620, donc même pas imaginable.
Pouvez vous effectuer un pré filtre avant ? Qui réduirait le nombre de combinaisons.

 

[mapomme]

Bonjour à tous

J'avais fait ce fichier il y a quelques temps:

• on peut aller jusqu'à 50 factures
• on accepte les avoir (factures négatives)
• on trouve aussi les solutions multiples
• la durée d’exécution est très raisonnable (de par la méthode)

nota : si on clique sur une solution, les polices des factures concerné passe en gras.

 

[sylvanu]

Bonjour Mapomme,
J'ai testé votre fichiers avec 50 factures, et une somme à trouver égale à 20 factures, mais mon XL a rendu l'âme.
Par quel mystère y parvenait vous, car le nombre de combinaisons est énorme.

 

[mapomme]

Par quel mystère y parvenait vous, car le nombre de combinaisons est énorme.

Bonjour @sylvanu

Pas de mystère!

C'est variable en fonction des montants des factures et de la somme globale à rechercher et de la répartition des montants des factures.
En particulier, plus la cible est élevée , plus c'est long (et c'est une des exceptions à l'adage "plus c'est long, plus c'est bon! )
J'avais fait cela pour un ami qui possédait une petite boite dont certains clients payaient en retard et avec des chèques dont le montant correspondait à plusieurs factures. Mais ce n'était pas le pire : certains réglaient des parties de factures (ça c'était la galère!). Enfin d'autres cumulaient les deux défauts!!!!

Ma méthode n'est pas la force brute. Je ne calcule pas toutes les combinaisons. Si je cherche le montant de 100, je peux éliminer d'emblée les factures supérieures à 100; ça devient une gestion de piles : j'empile et dépile avec un seuil haut pour arrêter d'empiler (la somme de la pile dépasse la cible - les montants sont bien sûr triés du plus petit au plus grand).
En revanche, inclure les avoirs a été un peu plus compliqué puisqu'on ne peut pas éliminer d'emblée les montant positifs supérieurs à la cible.

Peux-tu me renvoyer ton exemple qui bloque ? (ça m’intéresserai)

Tu es dans sans doute dans un mauvais cas. J'avais remarqué cela -> avoir comme solution un nombre de factures voisin de la moitié des factures (quand le nombre de facture est grand bien sûr).

nota : le tutoiement est permis.

 

[sylvanu]

Re Mapomme,
En fait j'ai dupliqué les factures présentes pour en avoir 50, et mis en Cible la somme des 20 premières 1106.89€.
Mon vieux 2007 rend l'âme.

 

[mapomme]

re-Bonsoir Sylvanu,

J'ai exécuté le fichier avec tes données: Voici les résultats :
30 factures => 1 106 solutions en 0,35 s
35 factures => 184 311 solutions en 36,5 s
37 factures => 976 044 solutions en 195 s
38 factures => échec car le nombre de solutions à afficher dépassera le nombre de lignes possibles sur une feuille

Conclusion :

• ton micro de 2007 n'est peut-être pas dépassé (il se fait vieux quand même)
• il faut trouver un moyen de limiter le nombre de solutions à afficher : privilégier les solutions avec les factures les plus anciennes ou les plus élevées, ou bien les combinaisons avec le plus de factures soldées ou encore autre chose

Le mieux est de ne pas laisser tant de factures impayées. Faire comme les sociétés allemandes : si livré alors ça doit être payé; et si pas payé, alors pas de prochaine livraison tant que pas payé. C'est radical pour être payé (même par les boîtes françaises).