How to duplicate rows

February 20, 2023

I want to duplicate each row in a worksheet 57 times per row, across 39 columns (after the result, meaning there would be 58 duplicates of each record).

So for example, I have included a snippet below of what some of my records look like now (take in mind, there are 39 columns, snippet cant snip the complete view):

And here is the result I am looking foR (Note: this example is with 10 duplicates for each row rather than 58, as the screenshot would be too large). The original file has over 5000 records, so I know whatever code I use will take a while to load, this is fine by me, I just want the result)

Here is the code I have used below, this does not duplicate the rows as such but ensures that each row has a gap of 57 blank rows between each row across the 39 columns (A to AM). This would be a longer and more complicated way of completing the task, as I would then have to find a way to fill in the blanks. Hence why I’m posting the question as there must be a more efficient way.

Sub Duplication()

Dim lastRow As Long
lastRow = Sheets("MasterSheet").Range("A" & Rows.Count).End(xlUp).Row

For i = lastRow To 3 Step -1
    Cells(i, 1).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 2).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 3).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 4).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 5).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 6).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 7).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 8).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 9).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 10).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 11).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 12).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 13).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 14).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 15).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 16).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 17).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 18).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 19).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 20).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 21).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 22).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 23).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 24).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 25).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 26).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 27).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 28).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 29).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 30).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 31).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 32).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 33).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 34).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 35).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 36).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 37).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 38).Resize(57).Insert Shift:=xlDown
Next
For i = lastRow To 3 Step -1
    Cells(i, 39).Resize(57).Insert Shift:=xlDown
Next    

End Sub

Please let me know what you think, apologies if there is a much easier solution I am currently unaware of. I tried looking on forums and other questions, but none par the code I have displayed gave me a result in the desired direction.

Thank you

>Solution :

You could take all data into array and the paste values from there looping:

Sub test()
Dim i As Long, j As Long
Dim LastColumn As Long, LastRow As Long
Dim MyData As Variant
Dim HowManyCopies As Long, MyCounter As Long, CurrentRow As Long

Application.ScreenUpdating = False

'get last column, in your case 39, here is just 4
LastColumn = 4

'get last non blank row
LastRow = Range("A" & Rows.Count).End(xlUp).Row

'all data into array, headers included
MyData = Range("A1").CurrentRegion.Value

'clear range except headers
Range(Cells(2, 1), Cells(LastRow, LastColumn)).Clear

'Duplicate rows. Loop trough each row of array
'we start at row 2 because 1 is headers

HowManyCopies = 4 'as example, just 4 duplicates of each row
CurrentRow = 2 'where to start duplicating

For i = 2 To UBound(MyData) Step 1
    'loop trough counter until HowManyCopies is reached
    For MyCounter = 1 To HowManyCopies Step 1
        'loop trough each column and paste value
        For j = 1 To LastColumn Step 1
            Cells(CurrentRow, j).Value = MyData(i, j)
        Next j
        CurrentRow = CurrentRow + 1
    Next MyCounter
Next i

Erase MyData 'clean variable

Application.ScreenUpdating = True
End Sub

The example above just duplicate a dataset of 5 rows and 4 columns each row 4 times but it’s easy to adapt to 5000 rows and 39 columns (it will take longer, tough).