Macro combinaison de cellules

Bonjour à toutes et tous et bonne année 2020 !

J'ai un casse tête pour bien commencer l'année :

Mon excel a deux colonnes (A:B).

En A1, je rentre une valeur cible.

En colonne B, j'ai plusieurs valeurs de B1 à Bn. La somme de certaines valeurs de cette colonne doit être égale à la valeur indiquée en A1.

J'aimerais donc faire une macro pour parcourir les combinaisons possibles (boucle While ?) jusqu'à ce que je trouve la solution et mettre en évidence (surlignage) les cellules B dont la somme est égale à A1.

L'exemple en pj est plus parlant..

Merci d'avance pour vos retours toujours d'une grande aide pour moi

Bien cordialement,

Mav'

Salut MAVERICK39,

vite fait, sans fioritures en ne cherchant une combinaison qu'entre deux nombres de [B:B] !

Doit-on chercher une solution combinant plus de deux nombres de ['B] ?

Si aucune solution n'est trouvée, [A1] se colore de rouge.

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim tTab, iNb%
'
If Not Intersect(Target, [A1]) Is Nothing Then
    iNb = CInt(Target)
    Range("A1:B" & Range("B" & Rows.Count).End(xlUp).Row).Interior.ColorIndex = 2
    tTab = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row).Value
    '
    For x = 1 To UBound(tTab, 1) - 1
        For y = 2 To UBound(tTab, 1)
            If y <> x And CInt(tTab(x, 1)) + CInt(tTab(y, 1)) = iNb Then
                iOK = 1
                Range("B" & x).Interior.ColorIndex = 4
                Range("B" & y).Interior.ColorIndex = 4
                Exit For
            End If
        Next
        If iOK = 1 Then Exit For
    Next
    [A1].Interior.ColorIndex = IIf(iOK = 0, 3, 4)
End If
'
End Sub

A+

38maverick39.xlsm (14.93 Ko)

Bonjour Curulis,

Merci beaucoup pour ta réponse.

C'est un bon début mais il est effectivement possible qu'il y ait une combinaison de plusieurs cellules et c'est là la principale difficulté

La mise en forme est super par contre !

A te lire

Bonjour à tous,

Tu peux utiliser le solveur en mode simplexe avec des variables binaires en regard de tes valeurs, une cellule objectif contenant la différence entre le SOMMEPROD(tes_valeurs;les_variables_binaires) et ta valeur_cible.

Tu choisis valeur et tu mets 0.

La seule contrainte porte sur les variables qui doivent être binaires.

Tu lances ton simplexe et tu obtiendras (le cas échéant) une solution à base de 0 et de 1 dans tes variables.

Tu n'as plus qu'à faire une MFC sur la valeur 1 de la variable.

Cordialement

PS : cette solution ne te donne qu'une solution, si elle existe bien sûr. Si tu en veux plusieurs, il faudra passer par une macro de type branch & cut. Je crois que eriiic en avait faite une..... je ne sais plus trop ni où ni quand.

Salut MAVERICK39,

Salut jvdo,

En supposant que ta liste de nombre en [B:B] peut être triée.

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim iRowB%, iNb%, iTot%, iIdx%, iOK%
'
If Not Intersect(Target, [A1]) Is Nothing Then
    iNb = CInt(Target)
    iRowB = Range("B" & Rows.Count).End(xlUp).Row
    Range("B1:B" & iRowB).Sort key1:=Range("B1"), order1:=xlDescending, Orientation:=xlSortColumns
    Range("A1:B" & iRowB).Interior.Color = xlNone
    '
    Do
        iTot = 0
        iIdx = iIdx + 1
        For x = iIdx To iRowB
            If iTot + CInt(Range("B" & x).Value) <= iNb Then
                Range("B" & x).Interior.ColorIndex = 4
                iTot = iTot + CInt(Range("B" & x).Value)
            End If
            If iTot = iNb Then iOK = 1
        Next
        If iOK = 0 Then Range("B1:B" & iRowB).Interior.Color = xlNone
    Loop Until iIdx = iRowB Or iOK = 1
    [A1].Interior.ColorIndex = IIf(iOK = 0, 3, 4)
    [A1].Select
End If
'
End Sub

A+

13maverick39.xlsm (22.44 Ko)

@ JVDO : Merci pour ta réponse, c'est une approche intéressante et simple à mettre en place. Je préfère cependant la version macro proposée par curulis car j'aurai à faire cette opération un grand nombre de fois et il semble moins chronophage d'utiliser une macro. Je la garde sous le coude si besoin.

@Curulis : Merci pour l'adaptation, pas de soucis pour le tri des valeurs. Cependant, cette version ne semble pas fonctionner avec des nombres réels (avec des décimales) mais uniquement avec des entiers. Méa culpa, je n'avais pas précisé ce point mais je travaille avec des nombres pouvant avoir des virgules. Que faut-il adapter à la procédure ? (je ne suis pas sur d'avoir compris ton code )

Salut MAVERICK39,

code adapté!

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim iRowB%, dblNb#, dblTot#, iIdx%, iOK%
'
If Not Intersect(Target, [A1]) Is Nothing Then
    dblNb = CDbl(Target)
    iRowB = Range("B" & Rows.Count).End(xlUp).Row
    Range("B1:B" & iRowB).Sort key1:=Range("B1"), order1:=xlDescending, Orientation:=xlSortColumns
    Range("A1:B" & iRowB).Interior.Color = xlNone
    '
    Do
        dblTot = 0
        iIdx = iIdx + 1
        For x = iIdx To iRowB
            If dblTot + CDbl(Range("B" & x).Value) <= dblNb Then
                Range("B" & x).Interior.ColorIndex = 4
                dblTot = dblTot + CDbl(Range("B" & x).Value)
            End If
            If dblTot = dblNb Then iOK = 1
        Next
        If iOK = 0 Then Range("B1:B" & iRowB).Interior.Color = xlNone
    Loop Until iIdx = iRowB Or iOK = 1
    [A1].Interior.ColorIndex = IIf(iOK = 0, 3, 4)
    [A1].Select
End If
'
End Sub

A+

22maverick39.xlsm (15.32 Ko)

Merci du fond du coeur Curulis !

C'est parfait, ce fichier va m'être d'une grande aide.

Maverick

Curulis,

Après avoir testé le fichier, il semblerait que la macro ne fonctionne pas sur certains exemples :

Test sur 2 exemples :

-colonne D : 5364.07 € (pour vérification de l’addition)

-colonne E : 4696.18 € (pour vérification de l’addition)

Sur ces 2 exemples, le test ne marche pas alors que les valeurs sont bien incluses en colonne B.

Le code a t-il une limite sur la taille de valeur à chercher ?

Désolé pour le dérangement, c'est très bien sinon

14macro-test.xlsm (15.30 Ko)

Bonjour,

te sort plusieurs solutions s'il y a :

https://mon-partage.fr/f/agr48e0j/

eric

Salut MAVERICK39,

Salut Eriiic,

j'ai justement travaillé une version plus aboutie cette nuit qui, en l'occurrence, donne de meilleurs résultats.

En cliquant en [B2], tu choisis d'obtenir une ou plusieurs combinaisons. Teste!

Cela dit, en y réfléchissant, il y a des flopées de combinaisons possibles que la macro n'est pas capable actuellement de dénicher et c'est logique au vu de sa construction.

A te lire,

A+

Curulis, Eriic

Merci à tous les deux, je ne sais pas quoi vous dire tellement que c'est bien !

Vous vous surpassez tous les uns les autres.

Merci infiniment !

j'ai pu noter que dans vos deux solutions, les doublons apparaissent. Sachant que les cases sont coloriées, j'imagine qu'il est possible de supprimer les doublons si le coloriage de deux colonnes est identique ?

Ca ne m'est pas utile du tout mais peut être que c'est une amélioration possible

Bonne journée et encore merci

Je colorie en vert lorsque la valeur exacte est trouvée.

Car il y a possibilité de rechercher à x% près. Là, la couleur varie selon l'éloignement.

Pour ma part, aucune solution n'est en doublon donc rien à supprimer.

Un 10.05 de la ligne 5 est considéré comme différent d'un 10.05 de la ligne 12, car peut être issu d'une autre facture. Et d'autre part, si présent 2 fois, il est susceptible de pouvoir apparaitre 2 fois dans la somme.

A toi de supprimer tes doublons de valeurs avant si besoin.

eric

Salut MAVERICK39,

Salut Eriiic,

oui, j'y travaille! Ça m'énerve car c'est certainement une bêtise...

Je reviens dès que j'ai corrigé l'affaire!

A+

Salut MAVERICK39,

Salut Eriiic,

- ce qu'il manquait quelque part pour éviter les doublons...

iIdx2 = iIdx3
  • pour te (surtout ME) simplifier la vie, il vaudrait mieux (comme dans le fichier joint) ajouter dans tes valeurs en [D:D] 0.01, 0.02, 0.04, 0.08 ;
  • ce code, tel qu'il est conçu, sera incapable de trouver certaines valeurs (aléatoires) : si, vraiment, cela te gêne aux entournures, je remettrai l'ouvrage sur le métier !!

A+

Pour moi les doublons de valeurs doivent être éliminés par l'utilisateur s'il pense que c'est une erreur.

On peut avoir 2 paiement de 10€ parfaitement justifiés et à utiliser tous les 2.

Ou alors je n'ai pas compris ce qu'il appelle un doublon.

C'est parfait, ne vous embêtez plus vos codes sont exactement ce qu'il me fallait.

Effectivement il peut y avoir plusieurs fois la même facture dans la liste des valeurs; J'appelais doublon, deux solutions qui utilisent exactement les mêmes termes mais sans doute reconnu différemment par la macro de part l'ordre des termes.

a+b+c = b+c+a = c+a+b = ...= doublons

Salut MAVERICK39,

Salut Eriiic,

Voilà les deux derniers problèmes réglés : un de vitesse et surtout la non-reconnaissance de combinaisons correctes pour un souci de précision entre valeurs doubles dont la solution m'a été apportée par Oxydum Merci à toi, Oxydum !

If Round(dblTot, 2) = Round(dblNb, 2) Then iOK = 1

Là, sauf modifications sur commande, je pense que c'est bon!

A+

Bonjour à tous,

Curulis, tu as aussi la solution d'utiliser des Currency.

Ce sont des entiers à 4 décimales fixes. Suffisants pour les calculs monétaires, plus de problème de précision et plus rapide que des Round parsemés un peu partout.

eric

Salut MAVERICK39,

Salut Eriiic,

@Eriiic : merci de contribuer à la solution du problème soulevé par ailleurs!

Suite à la réponse d'Oxydum, j'ai (enfin, me diras-tu... ) un peu plus creusé cette histoire.

Le terme 'flottant' ne m'avait jamais fait tilter : j'ai bien compris maintenant!

J'ai donc trouvé CDec, qui n'est pas un type de variable, mais une fonction de conversion qui "fixe" les éventuelles décimales (jusqu'à 28 décimales) d'une variable : plus d'erreur du tout!

Á part ce problème de décimales, il y avait quand même un dernier souci pour les combinaisons d'un nombre-cible existant dans la base de nombres. Réglé!

Je n'oserai plus dire que c'est fini mais, croisons les doigts!

Merci, Maverick, pour ce casse-tête qui m'aura appris plein de choses sans compter l'amusement à réaliser cette macro!

A+

Rechercher des sujets similaires à "macro combinaison"