Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.Max(Application.CountA(Columns(1)), Application.CountA(Columns(4))) + 1
Application.ScreenUpdating = False
Doublons Range("A3:C" & derlig - 1), 3
Doublons Range("D3:F" & derlig - 1), 3
For n = 3 To derlig - 1
If Cells(n, 4) <> "" Then
i = Application.Match(Cells(n, 4), Columns(1), 0)
If IsError(i) Then
Cells(n, 4).Resize(, 3).Cut Cells(derlig, 4) 'couper-coller
derlig = derlig + 1
ElseIf i <> n Then
Cells(n, 4).Resize(, 3).Cut
Cells(i, 4).Insert xlDown
End If
End If
Next
'---supprime les lignes entièrement vides---
For n = derlig - 1 To 3 Step -1
If Application.CountA(Rows(n)) = 0 Then Rows(n).Delete
Next
End Sub
Sub Doublons(plage As Range, col%)
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To plage.Rows.Count
x = plage(i, 1)
If x <> "" Then
If d.exists(x) Then
plage(d(x), col) = plage(d(x), col) + plage(i, col)
Else
d(x) = i 'mémorise la ligne
End If
End If
Next
plage.RemoveDuplicates 1, Header:=xlNo 'supprime les lignes en doublon
End Sub