Private Sub Worksheet_Activate()
Dim n&, crit As Range, i&, j&
Application.ScreenUpdating = False
Columns(1).Delete
[A1] = "Liste"
n = 1
With Sheets("Listes")
With .[C1].CurrentRegion
If .Rows.Count = 1 Then Exit Sub
Set crit = .Offset(1).Resize(.Rows.Count - 1)
End With
With .[A1].CurrentRegion
For i = 2 To .Rows.Count
If Application.CountIf(crit, .Cells(i, 1)) Then
If i > 2 And Application.CountIf(crit, .Cells(i - 1, 1)) = 0 Then
n = n + 1
.Cells(i - 1, 1).Copy Cells(n, 1)
End If
n = n + 1
.Cells(i, 1).Copy Cells(n, 1)
End If
Next
End With
End With
Columns(1).AutoFit
End Sub