XL 2010 Additionner des nombres jusqu'à atteindre une certaine valeur

PhilippeCam · 5 Février 2023

Bonjour à tous,

J'ai effectué des recherches sur le Forum, mais n'ai pas trouvé de réponse à mon problème.
Je cherche un moyen automatisé de trier une liste de valeur de manière à obtenir une somme approchant une valeur cible, et répéter l'opération jusqu'à la fin de la liste de valeurs.
Je joins un fichier pour illustrer ma demande, je n'arrive en effet pas à bien expliciter ma demande.

Mercis d'avance pour votre aide

job75 · 12 Février 2023

Voici la macro que vous attendez :

VB:

Sub Calcul()
Dim Lbarre, P As Range, nlig&, lig&, nbarre&, c As Range, i&
Lbarre = 6000
Set P = [A1].CurrentRegion
nlig = P.Rows.Count
Application.ScreenUpdating = False
P.Offset(1, 1).ClearContents
P.Offset(1, 1).Interior.ColorIndex = xlNone
lig = 2
1 If P(lig, 1) > Lbarre Then P(lig, 1).Select: MsgBox "Découpe erronée !", 48: Exit Sub
nbarre = nbarre + 1
P(lig, 2) = nbarre
P(lig, 3) = Lbarre '1ère barre
Set c = P(lig, 4)
c = Lbarre - P(lig, 1)
For i = lig + 1 To nlig
    If P(i, 1) < c And P(i, 2) = "" Then
        P(i, 2) = nbarre
        P(i, 4) = c - P(i, 1)
        Set c = P(i, 4)
    End If
Next i
c.Interior.ColorIndex = 6 'jaune
For i = lig + 1 To nlig
    If P(i, 2) = "" Then
        lig = i...

job75 · 13 Février 2023

Gégé-45550 à dit:
Juste un détail, A1 est exclue du calcul

Bien sûr puisque j'ai mis des en-têtes aux 4 colonnes.

Bonne nuit.

PhilippeCam · 13 Février 2023

job75 à dit:

Voici la macro que vous attendez :

VB:

Sub Calcul()
Dim Lbarre, P As Range, nlig&, lig&, nbarre&, c As Range, i&
Lbarre = 6000
Set P = [A1].CurrentRegion
nlig = P.Rows.Count
Application.ScreenUpdating = False
P.Offset(1, 1).ClearContents
P.Offset(1, 1).Interior.ColorIndex = xlNone
lig = 2
1 If P(lig, 1) > Lbarre Then P(lig, 1).Select: MsgBox "Découpe erronée !", 48: Exit Sub
nbarre = nbarre + 1
P(lig, 2) = nbarre
P(lig, 3) = Lbarre '1ère barre
Set c = P(lig, 4)
c = Lbarre - P(lig, 1)
For i = lig + 1 To nlig
    If P(i, 1) < c And P(i, 2) = "" Then
        P(i, 2) = nbarre
        P(i, 4) = c - P(i, 1)
        Set c = P(i, 4)
    End If
Next i
c.Interior.ColorIndex = 6 'jaune
For i = lig + 1 To nlig
    If P(i, 2) = "" Then
        lig = i
        GoTo 1
    End If
Next i
End Sub

Dans le fichier joint elle est affectée au bouton.

Chapeau bas, Job75...
C'est exactement la routine que je cherchais.
Merci mille fois.
@Gégé-45550 c'est normal que ça ne prenne pas en compte la première ligne, la routine débute à la ligne 2, la ligne 1 étant la ligne de titre.
Je mets le sujet Résolu.

XL 2010 Additionner des nombres jusqu'à atteindre une certaine valeur

PhilippeCam

XLDnaute Nouveau

Pièces jointes

job75

job75

XLDnaute Barbatruc

PhilippeCam

XLDnaute Nouveau

Discussions similaires