Sub toto()
Dim i&, l&, m&, Cel As Range
With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
Set Cel = [A3]
With [Y3]
Do While Not IsEmpty(.Offset(l, -11).Value)
If IsNumeric(.Offset(l).Value) Then
For i = 1 To .Offset(l).Value
.Offset(l, -11).Resize(1, 11).Copy Destination:=Cel.Offset(m, 1)
Cel.Offset(m) = m + 1
m = m + 1
Next
End If
l = l + 1
Loop
End With
l = m
Do Until IsEmpty(Cel.Offset(m)): m = m + 1: Loop
If m <> l Then Cel.Offset(l).Resize(m - l, 12).ClearContents
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End Sub