Macro combinaison de cellules Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
M
MAVERICK39
Membre habitué
Membre habitué
Messages : 101
Appréciation reçue : 1
Inscrit le : 2 août 2017
Version d'Excel : 2016

Message par MAVERICK39 » 4 janvier 2020, 15:39

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

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

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.. :D

Merci d'avance pour vos retours toujours d'une grande aide pour moi
Bien cordialement,
Mav'
exemple target.xlsx
(8.4 Kio) Téléchargé 5 fois
Avatar du membre
curulis57
Passionné d'Excel
Passionné d'Excel
Messages : 3'751
Appréciations reçues : 226
Inscrit le : 4 janvier 2016
Version d'Excel : 2016 FR / 2019 FR

Message par curulis57 » 4 janvier 2020, 16:39

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
:noel:
A+
MAVERICK39.xlsm
(14.93 Kio) Téléchargé 4 fois
M
MAVERICK39
Membre habitué
Membre habitué
Messages : 101
Appréciation reçue : 1
Inscrit le : 2 août 2017
Version d'Excel : 2016

Message par MAVERICK39 » 4 janvier 2020, 18:15

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
j
jvdo
Jeune membre
Jeune membre
Messages : 44
Appréciation reçue : 1
Inscrit le : 25 juillet 2018
Version d'Excel : 2010

Message par jvdo » 4 janvier 2020, 22:17

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.
Avatar du membre
curulis57
Passionné d'Excel
Passionné d'Excel
Messages : 3'751
Appréciations reçues : 226
Inscrit le : 4 janvier 2016
Version d'Excel : 2016 FR / 2019 FR

Message par curulis57 » 5 janvier 2020, 01:57

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
:btres:

:noel:
A+
MAVERICK39.xlsm
(22.44 Kio) Téléchargé 2 fois
M
MAVERICK39
Membre habitué
Membre habitué
Messages : 101
Appréciation reçue : 1
Inscrit le : 2 août 2017
Version d'Excel : 2016

Message par MAVERICK39 » 5 janvier 2020, 09:00

@ 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 :oops: )
Avatar du membre
curulis57
Passionné d'Excel
Passionné d'Excel
Messages : 3'751
Appréciations reçues : 226
Inscrit le : 4 janvier 2016
Version d'Excel : 2016 FR / 2019 FR

Message par curulis57 » 5 janvier 2020, 15:42

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
:noel:
A+
MAVERICK39.xlsm
(15.32 Kio) Téléchargé 3 fois
1 membre du forum aime ce message.
M
MAVERICK39
Membre habitué
Membre habitué
Messages : 101
Appréciation reçue : 1
Inscrit le : 2 août 2017
Version d'Excel : 2016

Message par MAVERICK39 » 5 janvier 2020, 18:16

Merci du fond du coeur Curulis ! :o
C'est parfait, ce fichier va m'être d'une grande aide.
Maverick
M
MAVERICK39
Membre habitué
Membre habitué
Messages : 101
Appréciation reçue : 1
Inscrit le : 2 août 2017
Version d'Excel : 2016

Message par MAVERICK39 » 6 janvier 2020, 11:33

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 :oops:
macro test.xlsm
(15.3 Kio) Téléchargé 2 fois
Avatar du membre
eriiic
Passionné d'Excel
Passionné d'Excel
Messages : 9'246
Appréciations reçues : 372
Inscrit le : 7 février 2010
Version d'Excel : 2010fr

Message par eriiic » 6 janvier 2020, 12:09

Bonjour,

te sort plusieurs solutions s'il y a :
https://mon-partage.fr/f/agr48e0j/
eric
1 membre du forum aime ce message.
En essayant continuellement, on finit par réussir.
Donc plus ça rate, plus on a de chances que ça marche.
(les Shadoks)

En plus du merci (si si, ça se fait !!!), penser à mettre en résolu. Merci
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message