Sub test()
Dim Tabl1, Ctr As Long, Tabl2(), I As Long, Dico As Object, J As Long, K As Long
Dim Ligne As Long
Set Dico = CreateObject("Scripting.Dictionary")
With Sheets("RESULTAT ATTENDU")
.Range("A2", .Cells(.Rows.Count, 5).End(xlUp)).Value = ""
End With
With Sheets("TEST")
Tabl1 = .Range("A2", .Cells(.Rows.Count, 5).End(xlUp))
'Excel 365 uniquement
Ctr = Application.CountA(Application.Unique(.Range("A2", _
.Cells(.Rows.Count, 1).End(xlUp))))
ReDim Tabl2(5, Ctr)
Ctr = -1
For I = 1 To UBound(Tabl1, 1)
If Not Dico.exists(Tabl1(I, 1)) Then
Dico.Add Tabl1(I, 1), Tabl1(I, 1)
Ctr = Ctr + 1
ReDim Preserve Tabl2(5, Ctr)
For J = 0 To 4
Tabl2(J, Ctr) = Tabl1(I, J + 1)
Next J
Tabl2(5, Ctr) = "min"
Ctr = Ctr + 1
ReDim Preserve Tabl2(5, Ctr)
For J = 0 To 4
Tabl2(J, Ctr) = Tabl1(I, J + 1)
Next J
Tabl2(5, Ctr) = "max"
Else
For K = 0 To UBound(Tabl2, 2)
If Tabl2(0, K) = Tabl1(I, 1) And Tabl2(5, K) = "min" Then
If Tabl2(1, K) < Tabl1(I, 2) Then
For J = 0 To 4
Tabl2(J, K) = Tabl1(I, J + 1)
Next J
End If
ElseIf Tabl2(0, K) = Tabl1(I, 1) And Tabl2(5, K) = "min" Then
If Tabl2(1, K) > Tabl1(I, 2) Then
For J = 0 To 4
Tabl2(J, K) = Tabl1(I, J + 1)
Next J
End If
End If
Next K
End If
Next I
End With
With Sheets("RESULTAT ATTENDU")
For I = 0 To UBound(Tabl2, 2) - 1
If Tabl2(0, I) = Tabl2(0, I + 1) And Tabl2(1, I) <> Tabl2(1, I + 1) Then
Ligne = Ligne + 2
For J = 0 To 4
.Cells(Ligne + 1, 1).Offset(, J) = Tabl2(J, I + 1)
.Cells(Ligne, 1).Offset(, J) = Tabl2(J, I)
Next
End If
Next I
End With
End Sub