Remise

Résolu

94michel -

Bonjour, et merci à vous tous pour votre aide.

je voudrais savoir si c'est possible sur un tableau avec plusieurs montants de savoir exactement les montants utilisés pour une remise spécifique.

encore une fois merci beaucoup

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

Afficher la suite

3 réponses

Réponse 1 / 3
yg_be Contributeur
bonjour, que veux-tu calculer?
0
1. 94michel Auteur
  
  bonjour,
  une remise de 4637,60€ avec un tableau de plusieurs montant en sélectionnant automatiquement les montants de la somme en remise.
  merci
  
  0
2. yg_be Contributeur
  
  @94michelque faut-il avoir comme résultat dans quelle cellule?
  
  0
3. 94michel Auteur
  
  j'ai envoyé le fichier excel en modèle sur mon partage, il faut juste par exemple changer la couleur des montants de chaque cellule pour arriver à la remise voulue.
  les cellules des colonnes A B C D sur 15 lignes sont notes des montants, dans la cellule E 1 le montant de la remise,idéal est une sélection automatique sur les connes A B C D des montants pour arriver à la remise.
  
  Merci
  
  0
4. yg_be Contributeur
  
  @94michelje vois bien tous les montants, mais je n'ai pas compris quel était le résultat final attendu.
  je ne comprends pas "changer la couleur", ni "arriver à la remise".
  
  0
5. Ghörgh Contributeur
  
  Si je comprend bien, tu veux que le fichier cherche les cellules dans A1:D15 qui additionnées font le montant que tu rentres en E1.
  C'est bien ça ?
  Si c'est le cas, le problème est qu'il y a plusieurs combinaison possible...
  Du coup sans plus de règles...
  
  0

yg_be Contributeur

suggestion:

Option Explicit

Type Coupon
     addr As String
     val As Currency
     selected As Boolean
End Type
Sub remise()
Dim tout As Range, cell As Range, coll() As Coupon, nbr As Integer, remise As Currency, i As Integer
Set tout = Sheets("Feuil1").[A1:D15]
remise = CCur(Sheets("Feuil1").[E1])
nbr = 0
For Each cell In tout
    If IsNumeric(cell) And cell <> "" Then
        nbr = nbr + 1
        ReDim Preserve coll(nbr)
        coll(nbr).addr = cell.address
        coll(nbr).val = CCur(cell.Value)
        coll(nbr).selected = False
    End If
Next cell
If match(remise, coll, 1) Then
    Debug.Print "ok"
    For i = 1 To nbr
        If coll(i).selected Then
            Debug.Print coll(i).val, coll(i).addr
            Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 3
        Else
            Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 1
        End If
    Next i
Else
    Debug.Print "NOK"
End If
End Sub
Private Function match(reste As Currency, coll() As Coupon, depth As Integer) As Boolean
If coll(depth).val = reste Then
    coll(depth).selected = True
    match = True
Else
    If depth = UBound(coll) Then
        match = False
    Else
        If match(reste, coll, depth + 1) Then
            match = True
        Else
            If coll(depth).val < reste Then
                coll(depth).selected = True
                If match(reste - coll(depth).val, coll, depth + 1) Then
                    match = True
                Else
                    coll(depth).selected = False
                    match = False
                End If
            End If
        End If
    End If
End If
End Function

yg_be Contributeur

variante:

Option Explicit

Type Coupon
     addr As String
     val As Currency
     selected As Boolean
End Type
Sub remise()
Dim tout As Range, cell As Range, coll() As Coupon, nbr As Integer, remise As Currency, i As Integer, total As Currency
Dim kp As Coupon
Set tout = Sheets("Feuil1").[A1:D15]
remise = CCur(Sheets("Feuil1").[E1])
nbr = 0
total = 0
For Each cell In tout
    If IsNumeric(cell) And cell <> "" Then
        nbr = nbr + 1
        ReDim Preserve coll(nbr)
        coll(nbr).addr = cell.address
        coll(nbr).val = CCur(cell.Value)
        total = total + coll(nbr).val
        coll(nbr).selected = False
    End If
Next cell
If match(remise, coll, 1, total) Then
    Debug.Print "ok"
    For i = 1 To nbr
        If coll(i).selected Then
            Debug.Print coll(i).val, coll(i).addr
            Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 4
        Else
            Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 1
        End If
    Next i
Else
    Debug.Print "NOK"
        For i = 1 To nbr
            Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 3
    Next i
End If
End Sub
Private Function match(reste As Currency, coll() As Coupon, depth As Integer, grandtotal As Currency) As Boolean
Dim curval As Currency, totalrestant As Currency
DoEvents
curval = coll(depth).val
If curval = reste Then
    coll(depth).selected = True
    match = True
    Exit Function
End If
If depth = UBound(coll) Then
    match = False
    Exit Function
End If
If curval < reste Then
    If match(reste - curval, coll, depth + 1, grandtotal - curval) Then
        coll(depth).selected = True
        match = True
        Exit Function
    End If
End If
totalrestant = grandtotal - curval
If reste <= totalrestant Then
    If match(reste, coll, depth + 1, totalrestant) Then
        match = True
        Exit Function
    End If
End If
match = False
End Function

94michel Auteur
merci beaucoup
ça fonctionne très bien
bonne soirée
0

yg_be Contributeur

@94michelcouleurs améliorées:

Option Explicit

Type Coupon
     addr As String
     val As Currency
     selected As Boolean
End Type
Sub remise()
Dim tout As Range, cell As Range, coll() As Coupon, nbr As Integer, remise As Currency, i As Integer, total As Currency
Dim kp As Coupon
Sheets("Feuil1").[E1].Font.ColorIndex = 1
Set tout = Sheets("Feuil1").[A1:D15]
remise = CCur(Sheets("Feuil1").[E1])
nbr = 0
total = 0
For Each cell In tout
    If IsNumeric(cell) And cell <> "" Then
        nbr = nbr + 1
        ReDim Preserve coll(nbr)
        coll(nbr).addr = cell.address
        coll(nbr).val = CCur(cell.Value)
        total = total + coll(nbr).val
        coll(nbr).selected = False
    End If
Next cell
For i = 1 To nbr
    Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 1
Next i
If match(remise, coll, 1, total) Then
    Debug.Print "ok"
    Sheets("Feuil1").[E1].Font.ColorIndex = 4
    For i = 1 To nbr
        If coll(i).selected Then
            Debug.Print coll(i).val, coll(i).addr
            Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 4
        Else
            Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 1
        End If
    Next i
Else
    Debug.Print "NOK"
    Sheets("Feuil1").[E1].Font.ColorIndex = 3
    For i = 1 To nbr
        Sheets("Feuil1").Range(coll(i).addr).Font.ColorIndex = 3
    Next i
End If
End Sub
Private Function match(reste As Currency, coll() As Coupon, depth As Integer, grandtotal As Currency) As Boolean
Dim curval As Currency, totalrestant As Currency
DoEvents
curval = coll(depth).val
If curval = reste Then
    coll(depth).selected = True
    match = True
    Exit Function
End If
If depth = UBound(coll) Then
    match = False
    Exit Function
End If
If curval < reste Then
    If match(reste - curval, coll, depth + 1, grandtotal - curval) Then
        coll(depth).selected = True
        match = True
        Exit Function
    End If
End If
totalrestant = grandtotal - curval
If reste <= totalrestant Then
    If match(reste, coll, depth + 1, totalrestant) Then
        match = True
        Exit Function
    End If
End If
match = False
End Function

Réponse 3 / 3
JvDo
Bonjour à tous,

eriiic a fait un travail intéressant sur la question que tu poses.
Si tu cherches toutes les solutions ou seulement un certain nombre, je te conseille de regarder son travail.

Si tu veux une solution, tu peux, en dehors de la macro de yg_be, utiliser le solveur d'excel.
Tu crées une zone (mes_variables_binaires) de même dimension que tes montants (15 par 4) et tu lui donnes la contrainte d'être binaire.
tu crées une formule : ma_remise-sommeprod(mes_montants*mes_variables_binaires) qui deviendra ton objectif avec valeur 0.

Tu choisis "simplexe" et tu lances le solveur qui te fournit une solution.

Tu peux mettre une MFC sur la zone de tes montants pour faire ressortir les valeurs choisies.

Cordialement
0
1. 94michel Auteur
  
  Bonsoir
  merci pour cette solution, mais je ne comprends pas trop, si tu peux m'envoyer mon fichier avec ta formule intégrée ça ne serait pas de refus.
  bonne soirée
  
  Encore une fois Merci a vous tous.
  
  0

Remise

3 réponses

Discussions similaires

Newsletters