Convertir plusieurs lignes du même intitulé en une colonne

Sub contact()
'créer tableau à partir de la liste de contact
Dim list As Object, cont As Object
Set list = Worksheets("liste") '<<< "liste" à remplacer par le nom de la feuille qui contient la liste à transposer en tableau
Set cont = Worksheets("contact") '<<< "contact" a remplacer par le nom de la feuille ou tu souhaite créer le tableau de contact

'suppression de l'ancien tableau
cont.Range("A1:XV" & cont.Range("A65536").End(xlUp).Row).ClearContents

'création des titres de colonnes
col = 0
For i = 1 To list.Range("A65536").End(xlUp).Row
If WorksheetFunction.CountIf(list.Range("A1:A" & i), list.Range("A" & i).Value) = 1 Then
col = col + 1
cont.Cells(1, col) = list.Range("A" & i).Value
End If
Next i

'ajout des infos
For j = 1 To list.Range("B65536").End(xlUp).Row
If list.Range("B" & j) <> "" Then
lib = list.Range("A" & j).Value
    For k = 1 To cont.Range("XV1").End(xlToLeft).Column
    If cont.Cells(1, k) = lib Then
    c = k
    End If
    Next k
        If c <> 1 Then
        cont.Cells(cont.Range("A65536").End(xlUp).Row, c) = list.Range("B" & j).Value
        Else
        cont.Cells(cont.Range("A65536").End(xlUp).Row + 1, c) = list.Range("B" & j).Value
        End If
End If
Next j
End Sub