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.

CodePudding user response：

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        

CodePudding user response：

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