Sub Dernier_Tri()
Application.CutCopyMode = False
'*********mise en place les variables
Dim ligne_active As Integer
Dim X As Range
Dim derniere_ligne_occupée As Integer
Dim nb_ref_ident As Integer
Dim total_colC As Long
'*********tri par composants et par dates Ascendantes
Sheets("Extraction_triee2").Select
Cells.Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ligne_active = 2 '<--pointeur de la ligne active
'****recherche premiere cellule vide (nommee "X") en col A, puis deduction de la cellule précédente non vide(derniere_ligne_occupee).
Set X = Range("A:A").Find("", , xlValues, xlWhole, , , False)
derniere_ligne_occupée = (X.Row) - 1
'****parcoure les cellules col A jusqu'a dernière cellule remplie
Do Until ligne_active > derniere_ligne_occupée
If Cells(ligne_active, 1) = Cells(ligne_active + 1, 1) Then '***si cellule du dessous= cellule du ligne_active
'recherche nombre de composant identiques aprés la cellule
nb_ref_ident = 0
total_colC = 0
' calcul la somme des ref colC
Do Until Cells(ligne_active + nb_ref_ident, 1) <> Cells(ligne_active, 1)
total_colC = total_colC + Cells(ligne_active + nb_ref_ident, 3)
nb_ref_ident = nb_ref_ident + 1
Loop
'si somme colC est > premiere ref col F
If total_colC > Cells(ligne_active, 6) Then
'conserver les doublons (ou en réduire le nombre)
ligne_active = nb_ref_ident + ligne_active - 1
Else
'supprimer tous les doublons
Range(Cells(ligne_active + 1, 1), Cells(ligne_active + nb_ref_ident - 1, 10)).ClearContents
ligne_active = nb_ref_ident + ligne_active - 1
End If
End If
ligne_active = ligne_active + 1
Loop
'*********tri par composants et par dates descendantes **********
Cells.Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.CutCopyMode = False
Range("D8").Select
End Sub