Sub es()
Dim t(), i As Long, m As Object, y As Byte, x As Long
Application.ScreenUpdating = 0
Set m = CreateObject("Scripting.Dictionary")
m.CompareMode = TextCompare
t = Feuil1.Range("a2:f" & Feuil1.Cells(Rows.Count, 1).End(3).Row).Value2
For i = 1 To UBound(t): m.Item(t(i, 2)) = m.Item(t(i, 2)) + 1: Next i
For i = 1 To UBound(t)
If m.Item(t(i, 2)) > 1 Then
x = x + 1
For y = 1 To 6: t(x, y) = t(i, y): Next y
End If
Next i
Feuil2.[j2].Resize(x, 6) = t
End Sub