transposer liste de noms

Sub Test()
   
    Dim Plage As Range
    Dim Cel As Range
    Dim Lig As Long
    Dim TxtDebut As String
    Dim TxtFin As String
    Dim TxtAnimal1 As String
    Dim TxtAnimal2 As String
    Dim I As Long
   
    With Worksheets("Feuil1")
   
        Set Plage = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
   
        Lig = 5
       
        For Each Cel In Plage
       
            I = I + 1
            TxtDebut = "                 <text font-size=""100"" x=""-110"" y=""50"" display=""none"" style=""font-size:15px;font-weight:bold;fill: #bbef0d;font-family:Verdana"">"
            TxtAnimal1 = "       <animate fill=""freeze"" dur=""0.1s"" begin=" & Format(I, "00") & ".mouseover"" from=""none"" to=""block"" attributeName=""display""></animate>"
            TxtAnimal2 = "       <animate fill=""freeze"" dur=""0.1s"" begin=" & Format(I, "00") & ".mouseout"" from=""block"" to=""none"" attributeName=""display""></animate>"
            TxtFin = "           </text>"
           
            .Cells(Lig, 4).Value = TxtDebut
            .Cells(Lig + 1, 4).Value = Cel.Value
            .Cells(Lig + 2, 4).Value = TxtAnimal1
            .Cells(Lig + 3, 4).Value = TxtAnimal2
            .Cells(Lig + 4, 4).Value = TxtFin
           
           Lig = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
           
        Next Cel
   
    End With
   
End Sub

.Columns(4).Cells.Clear