Microsoft 365 Fusionner des lignes en doubles( avec ID comme clé )

Sub Worksheet_Activate()
    Application.ScreenUpdating = False
    ' Efface matrice résultat
    [A:F].ClearContents
    ' Transfert données dans feuil2 et tri sur ID, puis tranfert dans array, et efface matrice
    DL = Sheets("feuil1").Range("A65500").End(xlUp).Row
    Range("A1:F" & DL) = Sheets("feuil1").Range("A1:F" & DL).Value
    Range("A:F").Resize(DL).Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes
    T = Range("A2:F" & DL)
    [A:F].ClearContents
    ' Comparaison ID et concaténation
    ReDim Tout(UBound(T)): IndTout = 0
    For L = 1 To UBound(T) - 1
        If T(L, 1) = T(L + 1, 1) Then
            Tout(IndTout) = T(L, 1)
            For i = 2 To 6
                Tout(IndTout) = Tout(IndTout) & " | " & T(L, i) & "  " & T(L + 1, i)
            Next i
            Tout(IndTout) = Mid(Tout(IndTout), 1, Len(Tout(IndTout)) - 1) ' Efface dernier |
            IndTout = IndTout + 1
        End If
    Next L
    ' Restitution array dans feuille et redimensionne colonne
    Range("A1").Resize(UBound(Tout)).Value = Application.Transpose(Tout)
    Columns.AutoFit
End Sub