Mise en page WORD extraction sous titre YOUTUBE

Option Explicit
'supprimer lignes vides
Sub Supprimer_si_vide()
    Dim Ligne As Long
    On Error Resume Next
    Ligne = Columns("A").Find("*", , , , , xlPrevious).Row
   Range("A2:A" & Ligne).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
'déplacer le texte
Sub For_X_to_Next_Ligne()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, Var As Variant
    Set FL1 = Worksheets("Feuil1")
    NoCol = 1 'lecture de la colonne A
    For NoLig = Split(FL1.UsedRange.Address, "$")(4) To 2 Step -2
        Var = FL1.Cells(NoLig, NoCol)
       FL1.Cells(NoLig - 1, NoCol) = FL1.Cells(NoLig - 1, NoCol) & " " & Var
     Rows(NoLig & ":" & NoLig).Delete Shift:=xlUp
    Next
    Set FL1 = Nothing
    Worksheets("Feuil1").Columns("A:A").AutoFit
End Sub