Sub Demo()
Dim Rg As Range
Application.ScreenUpdating = False
With Feuil1
Set Rg = .[A2].End(xlDown)
Do Until Rg.Row = .Rows.Count
With Rg.CurrentRegion.Rows
.Item("2:" & .Count).Offset(, .Columns.Count + 1).Value = .Item(1).Value
Set Rg = Rg(.Count).End(xlDown)
End With
Loop
End With
Set Rg = Nothing
End Sub