Obtenir une ligne avec toutes les infos des lignes sup. / noms

Option Explicit 

Sub test() 
Dim tabDonnees(), T_Out() As String 
Dim lngDrLig&, drCol&, i&, j&, k&, l&, m&, cpt& 

j = 0 
drCol = Range("A1").SpecialCells(xlCellTypeLastCell).Column 
lngDrLig = Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row 
tabDonnees = Range(Cells(1, 1), Cells(lngDrLig, drCol)) 
For i = 2 To UBound(tabDonnees, 1) 
    i = i - 1 
    cpt = 0 
    Do 
        i = i + 1 
        j = j + 1 
        cpt = cpt + 1 
        ReDim Preserve T_Out(1 To drCol, 1 To j) 
        For k = 1 To drCol 
            T_Out(k, j) = tabDonnees(i - 1, k) 
        Next k 
        If i = UBound(tabDonnees, 1) Then Exit Do 
    Loop While tabDonnees(i, 1) & tabDonnees(i, 2) = tabDonnees(i - 1, 1) & tabDonnees(i - 1, 2) 
    j = j + 1 
    ReDim Preserve T_Out(1 To drCol, 1 To j) 
    For l = 1 To drCol 
        For m = 1 To cpt 
            If T_Out(l, j) = "" Then 
                If T_Out(l, j - m) <> "" Then 
                    T_Out(l, j) = T_Out(l, j - m) 
                    Exit For 
                End If 
            Else 
                Exit For 
            End If 
        Next m 
    Next l 
Next i 
Application.ScreenUpdating = False 
With Sheets("Feuil2") 
    .Cells.Clear 
    For i = 1 To UBound(T_Out, 1) 
        For j = 1 To UBound(T_Out, 2) 
            .Cells(j, i) = T_Out(i, j) 
        Next 
    Next 
    .Rows(1).Delete 
    .Activate 
End With 
Application.ScreenUpdating = True 
End Sub