Copy and paste multiple times and loop - excel

Question

I have a problem in writing a code to copy and paste multiple times.
I have 2 sheets, where in sheet 1 I have 160 Rows and 3 columns.
I need to copy each row and paste 15 times in sheet 2.
can anyone help me to sort it out.

Answer 1

Given that you keep your three columns as you stated and the headers in row 1, you achieve what you say by changing the ranges dynamically in a simple for loop
Sub copy_15()
Application.ScreenUpdating = False
With Worksheets("Sheet2")
Dim wS2 As Range
Set wS2 = .Range("A1").CurrentRegion
wS2.ClearContents
'Copy headers
Worksheets("Sheet1").Range("A1:C1").Copy
.Range("A1").PasteSpecial
End With
Dim lastRow1 As Long: lastRow1 = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow1
Worksheets("Sheet1").Range("A" & i & ":C" & i).Copy
Dim lastRow2 As Long: lastRow2 = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("Sheet2").Range("A" & lastRow2 + 1 & ":C" & lastRow2 + 15).PasteSpecial
Next i
Application.CutCopyMode = False
End Sub

Answer 2

Return Repeated Rows in Another Worksheet
Sub RepeatRows()
' Source
Const sName As String = "Sheet1"
Const sFirstRowAddress As String = "A2:C2"
' Destination
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A2"
Dim RepeatCount As Variant
Dim msg As Long
Do
RepeatCount = InputBox("How many Times")
If IsNumeric(RepeatCount) Then
If Len(RepeatCount) = Len(Int(RepeatCount)) Then
If RepeatCount > 0 Then Exit Do
End If
End If
msg = MsgBox("Not a valid entry.", vbYesNo + vbCritical, "Try again?")
If msg = vbNo Then Exit Sub
Loop
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sData As Variant
Dim srCount As Long
Dim cCount As Long
With sws.Range(sFirstRowAddress)
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data
srCount = lCell.Row - .Row + 1
cCount = .Columns.Count
If srCount + cCount = 2 Then ' one cell
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
Else ' multiple cells
sData = .Resize(srCount).Value
End If
End With
Dim drCount As Long: drCount = srCount * RepeatCount
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim sr As Long
Dim n As Long
Dim c As Long
Dim dr As Long
For sr = 1 To srCount
For n = 1 To RepeatCount
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
Next n
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, cCount)
.Resize(drCount).Value = dData
.Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
End With
MsgBox "Rows repeated.", vbInformation
End Sub