Need Macro- Copy Row and Insert 10 times

Sub test()
    Dim j As Integer, r As Range, c As Range, r1 As Range, r2 As Range
    j = 10
    Application.ScreenUpdating = False
    Worksheets("sheet3").Cells.Clear
    Set r = Range(Range("A2"), Range("A2").End(xlDown))
    For Each c In r
        Range(c, c.End(xlToRight)).Copy

        With Worksheets("sheet3")
            Set r1 = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Range(r1, r1.Offset(j - 1, 0)).PasteSpecial
        End With
    Next c
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub