Aide Excel, lignes différement renseignées...

Sub titres()
Dim derlig As Integer, cptr As Integer
Dim coll As Collection
Dim tablo
Dim titre As String, nbre_titre As Integer, lig As Integer, cptr_lig As Integer, cptr_tab As Byte

derlig = Range("J20000").End(xlUp).Row
'liste titres uniques
Set coll = New Collection
For cptr = 2 To derlig
On Error Resume Next
    coll.Add Cells(cptr, 10).Value, CStr(Cells(cptr, 10).Value)
Next

ReDim tablo(1 To coll.Count, 1 To 14)

For cptr = 1 To coll.Count
    'nombre occurence du titre en cours
    titre = coll(cptr)
    nbre_titre = Application.CountIf(Range("J2:J20000"), titre)
   
    'trouve les lignes des occurences du titre
     lig = 1
    For cptr_lig = 1 To nbre_titre
        lig = Columns(10).Find(titre, Cells(lig, 10)).Row
        'remplissage du tableau
        For cptr_tab = 1 To 14
            If Cells(lig, cptr_tab) <> "" Then tablo(cptr, cptr_tab) = Cells(lig, cptr_tab)
        Next
    Next
Next

'restitution du tableau en feuille2
Application.ScreenUpdating = False
With Sheets(2)
 .Range("A2:N20000").Clear
 .Range("A2").Resize(coll.Count, 14) = tablo
 .Range("A2:N" & coll.Count + 1).Borders.Weight = xlThin
End With

Set Collection = Nothing
End Sub