Suppression doublons et tableau activite

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, t As Long, dico As Object, txt As String
    Set dico = CreateObject("Scripting.Dictionary")
    a = Sheets("Départ").Range("a1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) + 1, 1 To UBound(a, 1) + 2)
    n = 1: t = 3: b(1, 1) = a(1, 1)
    b(1, 2) = a(1, 2): b(1, 3) = a(1, 3)
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)), Chr(2))
            If Not dico.exists(txt) Then
                n = n + 1: dico(txt) = n
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 2)
                b(n, 3) = a(i, 3)
            End If
            If Not .exists(a(i, 3)) Then
                t = t + 1: .Item(a(i, 3)) = t
                b(1, t) = a(i, 3)
            End If
            b(dico(txt), .Item(a(i, 3))) = "x"
        Next
    End With
    Application.ScreenUpdating = False
    'restitution et mise en forme
    With Sheets("Arrivée")
        .Cells.Clear
        With .Cells(1).Resize(n, t)
            .Value = b
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Rows(1).BorderAround Weight:=xlThin
            .Columns.ColumnWidth = 12
        End With
        .Activate
    End With
    Application.ScreenUpdating = True
End Sub