XL 2016 Doublons

Private Sub Worksheet_Activate()
Dim d As Object, plage As Range, nlig%, c As Range, x$, n%, resu(), col%, lig%
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Cells.Delete 'RAZ
Set plage = Feuil1.[A1].CurrentRegion.Rows(1).Cells
nlig = plage.Count + 2
For Each c In plage
    x = c
    If Not d.exists(x) Then
        n = n + 1
        d(x) = n 'mémorise le rang
        ReDim Preserve resu(1 To nlig, 1 To n)
        resu(1, n) = x
        resu(2, n) = 2
    End If
    col = d(x)
    lig = resu(2, col) + 1: resu(2, col) = lig
    resu(lig, col) = c(2)
Next
[A1].Resize(nlig, n) = resu
Rows(2).Delete
Columns.AutoFit 'ajustement largeurs
End Sub

Sub Worksheet_Activate()
With Sheets("Feuil1")
    DC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    tablo = .Range(.Cells(1, 1), .Cells(2, DC))
End With
Cells.Clear
ReDim T(1 To 3 * DC, 1 To 3 * DC): C = -2: L = 1
For i = 1 To UBound(tablo, 2)
    If tablo(1, i) <> "" Then
        C = C + 3: Classe = tablo(1, i): T(1, C) = Classe: T(L, C + 1) = tablo(2, i): tablo(1, i) = ""
        For j = i + 1 To UBound(tablo, 2)
            If tablo(1, j) = Classe Then L = L + 1: T(L, C + 1) = tablo(2, j): tablo(1, j) = "":
        Next j
        T(1, C + 2) = "---":  L = 1
    End If
Next i
T(1, C + 2) = "": [A1].Resize(UBound(T, 1), UBound(T, 2)) = T: Columns.AutoFit
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, r As Range, nlig%, n%, x$, resu(), col%, lig%
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Cells.Clear 'RAZ
Set r = Feuil1.[A1].CurrentRegion.Rows(1).Cells
nlig = r.Count
n = 1
For Each r In r
    x = r
    If Not d.exists(x) Then
        d(x) = n 'mémorise le rang
        ReDim Preserve resu(1 To nlig, 1 To n + 2)
        resu(1, n + 1) = x
        n = n + 3
    End If
    col = d(x)
    lig = resu(1, col) + 1: resu(1, col) = lig 'numérotation
    resu(lig, col + 2) = r(2)
Next
[A1].Resize(nlig, n - 1) = resu
With Rows(1).SpecialCells(xlCellTypeConstants, 1)
    .ColumnWidth = 2
    .ClearContents 'efface la numérotation
End With
Columns(1).Delete
End Sub