Sub RunMe() Dim mQ, y As Integer, x As Long Application.ScreenUpdating = False x = 2 Do mQ = Range("A" & x).Value - 1 If mQ <> 0 Then For y = 1 To mQ Rows(x).Copy Rows(x + 1).Insert Next y Range(Cells(x + 1, "A"), Cells(x + mQ, "A")).ClearContents End If x = x + mQ + 1 Loop Until Range("A" & x).Value = vbNullString Application.ScreenUpdating = True End Sub