Sub Liste_Couple()
Dim Tablo() As Variant, MonDico As Object
Dim f As Integer, c As Long, DerL As Long, t As String
Application.ScreenUpdating = False
WsLC.Cells.ClearContents
WsCP.Activate
Set MonDico = CreateObject("Scripting.Dictionary")
DerL = Cells(Rows.Count, 6).End(xlUp).Row
With WsCP
For c = 13 To DerL Step 4
If Cells(c, 6) = 0 And Cells(c, 7) = 1 Then
t = Cells(c, 6).Offset(-2, 5).Value & ";" & Cells(c, 6).Offset(-1, 5).Value
If Not MonDico.Exists(t) Then
MonDico.Add t, t
f = f + 1
ReDim Preserve Tablo(1 To 2, 1 To f)
Tablo(1, f) = Cells(c, 6).Offset(-2, 5).Value
Tablo(2, f) = Cells(c, 6).Offset(-1, 5).Value
End If
End If
Next c
End With
WsLC.Activate
WsLC.Range(Cells(5, 4), Cells(f + 4, 5)).Value = Application.WorksheetFunction.Transpose(Tablo)
Application.ScreenUpdating = True
End Sub