XL 2019 Meilleure option suivant les valeurs

cotignac

XLDnaute Nouveau
Bonjour,

Je cherche à connaître la meilleure option dans le fichier ci-joint. Cette option étant représenté par exemple par :
A1-B2-C4-D6-E8-F3
A chaque valeur est associée deux nombres, ex : A1 est associée à 0,15 et 15.
Il s'agit d'avoir un seul élément de type A, puis un seul élément de type B, un seul élément de type C etc..
La contrainte est matérialisée en B1 et B2 pour la fourchette de valeur où doivent se situer la somme des valeurs des colonnes D, H, L, P, T, X.
La meilleure option étant ensuite le nombre le plus haut de la somme des colonnes E, I, M, Q, U, Y.
J'aimerai, si c'est faisable, obtenir à partir de mon tableau une liste respectant la contrainte donnée par B1 et B2, où l'on aurait par exemple :
A7-B28-C2 -D3-E1-F3 puis 2 (somme des valeurs des colonnes intermédiaires) et 293 (sommes des valeurs des dernières colonnes).
L'idéal étant de pouvoir changer les valeurs B1 et B2 si nécessaire pour modifier la liste.

En vous remerciant par avance pour votre aide,
 

Pièces jointes

  • Calculs-options.xlsx
    11.2 KB · Affichages: 8
Solution
Il peut exister plusieurs listes optimales avec le même maximum Somme 2.

Pour les trouver toutes il faut modifier la macro :
VB:
Sub Calcul()
Dim inf, sup, A, ua&, B, ub&, C, uc&, D, ud&, E, ue&, F, uf&, liste$(), aa&, bb&, cc&, dd&, ee&, ff&, s1#, s2#, mem2#, i%, mem1#()
inf = [B1]
sup = [B2]
A = [C5].CurrentRegion: ua = UBound(A)
B = [G5].CurrentRegion: ub = UBound(B)
C = [K5].CurrentRegion: uc = UBound(C)
D = [O5].CurrentRegion: ud = UBound(D)
E = [S5].CurrentRegion: ue = UBound(E)
F = [W5].CurrentRegion: uf = UBound(F)
ReDim liste(0)
For aa = 1 To ua
    For bb = 1 To ub
        For cc = 1 To uc
            For dd = 1 To ud
                For ee = 1 To ue
                    For ff = 1 To uf
                        s1 = A(aa, 2) +...

JHA

XLDnaute Barbatruc
Bonjour à tous,

Avec ce que je comprends, je fais ressortir la plus grande valeur étant dans la limite haute et basse.

Après, je n'ai pas compris ce que tu veux de ces valeurs, je me suis donc arrêté là.

JHA
 

job75

XLDnaute Barbatruc
Bonjour cotignac, JHA, le forum,

Voici une solution VBA, le plus simple est d'étudier toutes les combinaisons possibles :
VB:
Sub Calcul()
Dim inf, sup, A, ua&, B, ub&, C, uc&, D, ud&, E, ue&, F, uf&, aa&, bb&, cc&, dd&, ee&, ff&, s1#, s2#, liste$, mem2#, mem1#
inf = [B1]
sup = [B2]
A = [C5].CurrentRegion: ua = UBound(A)
B = [G5].CurrentRegion: ub = UBound(B)
C = [K5].CurrentRegion: uc = UBound(C)
D = [O5].CurrentRegion: ud = UBound(D)
E = [S5].CurrentRegion: ue = UBound(E)
F = [W5].CurrentRegion: uf = UBound(F)
For aa = 1 To ua
    For bb = 1 To ub
        For cc = 1 To uc
            For dd = 1 To ud
                For ee = 1 To ue
                    For ff = 1 To uf
                        s1 = A(aa, 2) + B(bb, 2) + C(cc, 2) + D(dd, 2) + E(ee, 2) + F(ff, 2)
                        If s1 >= inf And s1 <= sup Then
                            s2 = A(aa, 3) + B(bb, 3) + C(cc, 3) + D(dd, 3) + E(ee, 3) + F(ff, 3)
                            If s2 > mem2 Then
                                liste = A(aa, 1) & "-" & B(bb, 1) & "-" & C(cc, 1) & "-" & D(dd, 1) & "-" & E(ee, 1) & "-" & F(ff, 1)
                                mem1 = s1
                                mem2 = s2
                            End If
                        End If
Next ff, ee, dd, cc, bb, aa
If liste = "" Then [G1:G3] = "": Exit Sub
[G1] = liste
[G2] = mem1
[G3] = mem2
End Sub
A+
 

Pièces jointes

  • Calculs-options.xlsm
    22.3 KB · Affichages: 8
Dernière édition:

cotignac

XLDnaute Nouveau
Bonjour cotignac, JHA, le forum,

Voici une solution VBA, le plus simple est d'étudier toutes les combinaisons possibles :
VB:
Sub Calcul()
Dim inf, sup, A, ua&, B, ub&, C, uc&, D, ud&, E, ue&, F, uf&, aa&, bb&, cc&, dd&, ee&, ff&, s1#, s2#, liste$, mem2#, mem1#
inf = [B1]
sup = [B2]
A = [C5].CurrentRegion: ua = UBound(A)
B = [G5].CurrentRegion: ub = UBound(B)
C = [K5].CurrentRegion: uc = UBound(C)
D = [O5].CurrentRegion: ud = UBound(D)
E = [S5].CurrentRegion: ue = UBound(E)
F = [W5].CurrentRegion: uf = UBound(F)
For aa = 1 To ua
    For bb = 1 To ub
        For cc = 1 To uc
            For dd = 1 To ud
                For ee = 1 To ue
                    For ff = 1 To uf
                        s1 = A(aa, 2) + B(bb, 2) + C(cc, 2) + D(dd, 2) + E(ee, 2) + F(ff, 2)
                        If s1 >= inf And s1 <= sup Then
                            s2 = A(aa, 3) + B(bb, 3) + C(cc, 3) + D(dd, 3) + E(ee, 3) + F(ff, 3)
                            If s2 > mem2 Then
                                liste = A(aa, 1) & "-" & B(bb, 1) & "-" & C(cc, 1) & "-" & D(dd, 1) & "-" & E(ee, 1) & "-" & F(ff, 1)
                                mem1 = s1
                                mem2 = s2
                            End If
                        End If
Next ff, ee, dd, cc, bb, aa
If liste = "" Then [G1:G3] = "": Exit Sub
[G1] = liste
[G2] = mem1
[G3] = mem2
End Sub
A+
Merci à tous les deux pour vos retours, la solution est parfaite job75, un grand merci
 

job75

XLDnaute Barbatruc
Il peut exister plusieurs listes optimales avec le même maximum Somme 2.

Pour les trouver toutes il faut modifier la macro :
VB:
Sub Calcul()
Dim inf, sup, A, ua&, B, ub&, C, uc&, D, ud&, E, ue&, F, uf&, liste$(), aa&, bb&, cc&, dd&, ee&, ff&, s1#, s2#, mem2#, i%, mem1#()
inf = [B1]
sup = [B2]
A = [C5].CurrentRegion: ua = UBound(A)
B = [G5].CurrentRegion: ub = UBound(B)
C = [K5].CurrentRegion: uc = UBound(C)
D = [O5].CurrentRegion: ud = UBound(D)
E = [S5].CurrentRegion: ue = UBound(E)
F = [W5].CurrentRegion: uf = UBound(F)
ReDim liste(0)
For aa = 1 To ua
    For bb = 1 To ub
        For cc = 1 To uc
            For dd = 1 To ud
                For ee = 1 To ue
                    For ff = 1 To uf
                        s1 = A(aa, 2) + B(bb, 2) + C(cc, 2) + D(dd, 2) + E(ee, 2) + F(ff, 2)
                        If s1 >= inf And s1 <= sup Then
                            s2 = A(aa, 3) + B(bb, 3) + C(cc, 3) + D(dd, 3) + E(ee, 3) + F(ff, 3)
                            If s2 > mem2 Then
                                i = 0
                                ReDim liste(0): ReDim mem1(0)
                                liste(0) = A(aa, 1) & "-" & B(bb, 1) & "-" & C(cc, 1) & "-" & D(dd, 1) & "-" & E(ee, 1) & "-" & F(ff, 1)
                                mem1(0) = s1
                                mem2 = s2
                            ElseIf s2 = mem2 Then
                                i = i + 1
                                ReDim Preserve liste(i): ReDim Preserve mem1(i)
                                liste(i) = A(aa, 1) & "-" & B(bb, 1) & "-" & C(cc, 1) & "-" & D(dd, 1) & "-" & E(ee, 1) & "-" & F(ff, 1)
                                mem1(i) = s1
                            End If
                        End If
Next ff, ee, dd, cc, bb, aa
'---restitution---
Application.ScreenUpdating = False
[K1].Resize(3, Columns.Count - 10).Delete xlToLeft
[G1:J3] = ""
If liste(0) = "" Then Exit Sub
For i = 0 To UBound(liste)
    [G1:J3].Copy [G1].Offset(, 4 * i)
    [G1].Offset(, 4 * i) = liste(i)
    [G2].Offset(, 4 * i) = mem1(i)
    [G3].Offset(, 4 * i) = mem2
Next i
End Sub
Les variables liste et mem1 sont maintenant des variables tableaux (Array).
 

Pièces jointes

  • Calculs-options(1).xlsm
    23.7 KB · Affichages: 4

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
313 259
Messages
2 096 617
Membres
106 688
dernier inscrit
Cherif99