Supprimer lignes jusqu'à atteindre les sommes voulues

bonjour,

je souhaite par macro supprimer les lignes dans l'onglet Feuil1 par nom de personne en partant du bas jusqu'à être inférieur aux sommes cibles dans l'onglet objectif (en jaunes).

pouvez vous m'aider ?

merci d'avance

Hello,

ça devrait le faire

Sub Supprimer_lignes_jusqu_a_atteindre_les_sommes_voulues()

    Dim Feuille_Donnees As Worksheet
    Dim Feuille_Objectifs As Worksheet
    Dim Der_Lig_Donnees As Long
    Dim Der_Lig_Objectifs As Long
    Dim Nom_Objectif As String
    Dim Somme_Cible As Double
    Dim Somme_Actuelle As Double
    Dim Nb_Nom As Long
    Dim i As Long

    Set Feuille_Donnees = ThisWorkbook.Sheets("Feuil1")
    Set Feuille_Objectifs = ThisWorkbook.Sheets("OBJECTIFS")

    ' Trouver la dernière ligne de données dans Feuille_Donnees
    Der_Lig_Donnees = Feuille_Donnees.Cells(Feuille_Donnees.Rows.Count, "A").End(xlUp).Row

    ' Trouver la dernière ligne dans Feuille_Objectifs
    Der_Lig_Objectifs = Feuille_Objectifs.Cells(Feuille_Objectifs.Rows.Count, "A").End(xlUp).Row

    ' Pour chaque Nom_Objectif de Feuille_Objectifs
    For Nb_Nom = 2 To Der_Lig_Objectifs

        Nom_Objectif = Feuille_Objectifs.Cells(Nb_Nom, 1).Value
        Somme_Cible = Feuille_Objectifs.Cells(Nb_Nom, 2).Value

        With Feuille_Donnees

            ' Calculer la somme actuelle pour ce Nom_Cible dans Feuille_Donnees
            Somme_Actuelle = Application.WorksheetFunction.SumIf(.Range("A2:A" & Der_Lig_Donnees), Nom_Objectif, .Range("B2:B" & Der_Lig_Donnees))

            ' Supprimer les lignes du bas tant que la somme actuelle dépasse la somme cible
            For i = Der_Lig_Donnees To 2 Step -1 ' Partir de la fin

                If .Cells(i, 1).Value = Nom_Objectif Then
                    If Somme_Actuelle > Somme_Cible Then
                        Somme_Actuelle = Somme_Actuelle - .Cells(i, 2).Value
                        .Rows(i).Delete
                    End If
                End If

            Next i
        End With

    Next Nb_Nom

End Sub

Bonjour,

Voici une proposition en VBA. A améliorer afin de choisir le prénom, actuellement dans mon code j'ai choisi "joe"

Double cliick sur la feuille pour actionner le code

c'est parfait !

merci à vous 2!

Bonjour,

Autre proposition, plus rapide, si le nombre de lignes est important

Sub Calculs()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, DerLig_f2 As Long, i As Long, j As Long, Objectif As Long, Total As Long
    Dim Nom As String
    Deb = Timer

    Application.ScreenUpdating = False
    Set f1 = Sheets("Feuil1")
    Set f2 = Sheets("OBJECTIFS")
    DerLig_f1 = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerLig_f2 = f2.Range("A" & Rows.Count).End(xlUp).Row

    'Numéroter les lignes, ceci pour retrouver la configuration de départ
    f1.Range("C1:C" & DerLig_f1).FormulaR1C1 = "=ROW()"
    f1.Range("C1:C" & DerLig_f1).Value = f1.Range("C1:C" & DerLig_f1).Value

    'tri par nom
    f1.Range("A2:C" & DerLig_f1).Sort [A1], 1

    'Calculs
    For i = DerLig_f1 To 2 Step -1
        Nom = f1.Cells(i, "A")
        Objectif = Application.WorksheetFunction.VLookup(Nom, f2.Range("A1:B" & DerLig_f2), 2, 0)
        Total = Application.WorksheetFunction.SumIf(f1.Range("A2:A" & DerLig_f1), Nom, f1.Range("B2:B" & DerLig_f1))
        'Relevés des objectifs

        If f1.Cells(i, "A") = Nom Then
            j = i
            Do While f1.Cells(j, "A") = Nom And Total > Objectif
                Total = Total - f1.Cells(j, "B")
                f1.Rows(j).Delete
                j = j - 1
            Loop
        End If
        Do While f1.Cells(j, "A") = Nom
            j = j - 1
        Loop
        i = j + 1
    Next i

    'tri de nouveau pour retrouver la configuration d'origine
    f1.Range("A2:C" & DerLig_f1).Sort [C1], 1

    f1.Columns(1).Delete
    Set f1 = Nothing
    Set f2 = Nothing
    MsgBox Timer - Deb
End Sub

Cdlt