Transformer plusieurs lignes en une ligne

Sub rassemble()
Dim TabIni() As Variant
With ActiveSheet
    Fin = .Range("G" & .Rows.Count).End(xlUp).Row
    TabIni = .Range("F5:G" & Fin).Value
    TailleFinale = WorksheetFunction.CountA(.Range("F5:F" & Fin))
    ReDim TabFinal(1 To TailleFinale, 1 To 1)
End With
k = 1
For i = LBound(TabIni, 1) To UBound(TabIni, 1)
    If TabIni(i, 1) <> "" Then
        TabFinal(k, 1) = TabIni(i, 1)
       
        j = i
       
        While TabIni(j + 1, 1) = "" And j <= Fin - 5
            TabFinal(k, 1) = TabFinal(k, 1) & "," & TabIni(j + 1, 2)
            j = j + 1
            If j = Fin - 4 Then GoTo recopie
        Wend
        k = k + 1
    End If
Next i
recopie:
With Sheets("Feuil2")
    .Range("A1").Resize(UBound(TabFinal, 1), UBound(TabFinal, 2)) = TabFinal
    .Range("B:B").Clear
End With
End Sub

Sub Concatener()
Dim tablo, resu(), i&, n&
With [F5].CurrentRegion
    tablo = .Resize(, 2)
    ReDim resu(1 To UBound(tablo), 1 To 1)
    For i = 1 To UBound(tablo)
        If tablo(i, 1) <> "" Then n = n + 1: resu(n, 1) = tablo(i, 1)
        If n Then resu(n, 1) = resu(n, 1) & tablo(i, 2)
    Next
    Application.ScreenUpdating = False
    If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
    .ClearContents 'RAZ
    If n Then .Resize(n, 1) = resu 'restitution
    With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
End Sub