Pfthb

I have to work on files with 5000 rows, for each row I have to insert 3 more rows and copy the content in these new rows (after that there will be more steps).
My macro works fine but the process of copying the content is really slow, I´m sure there is a solution that works better, any ideas?

Sub copy_rows()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Lastrow = Lastrow * 4

For i = 1 To Lastrow Step 4
Cells(i, 7).EntireRow.Offset(1).Resize(3).Insert Shift:=xlDown
Rows(i).Copy Destination:=Rows(i + 1)
Rows(i).Copy Destination:=Rows(i + 2)
Rows(i).Copy Destination:=Rows(i + 3)
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

End Sub

Thank you very much

When it comes to speed:

Accessing Excel data in VBA is slow, inserting a row (or column) is insane slow, while everything done in memory (VBA variables) is so fast that you can nearly not measure it.

So my suggestion is to read all the data from your worksheet into memory, "multiply" the rows there and write everything back all at once.

The following code example reads the data in a 2-dimensional array and copy it into a 2nd array that's 4 times as large. This 2nd array is written back to the sheet. I tested it with 1000 rows and execution time was 0s.

Drawback: you maybe have to take care about formatting

With ActiveSheet
 Dim lastRow As Long, lastCol As Long

 lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
 lastRow = .Cells(.Rows.Count, 1).End(xlUp).row

 Dim origData, copyData
 origData = .Range(.Cells(1, 1), .Cells(lastRow, lastCol)) ' Read data from sheet
 ReDim copyData(1 To lastRow * 4, 1 To lastCol) ' new array is 4 times the size
 Dim r As Long, c As Long, i As Long
 For r = 1 To lastRow ' All rows in orig data
 For c = 1 To lastCol ' All columns in orig data
 For i = 1 To 4 ' Copy everything 4 times
 copyData((r - 1) * 4 + i, c) = origData(r, c)
 Next i
 Next c
 Next r
 .Range(.Cells(1, 1), .Cells(lastRow * 4, lastCol)) = copyData ' Write back to sheet

End With

Probably the fastest way, if you are not interested in format, but only in the values:

Sub TestMe()

 With Worksheets(1)
 .Rows(1).Value = .Rows(2).Value
 End With

End Sub

FunThomas is right and that should be the quickest way, but if that's not an option it's a lot quicker not to copy the whole row.

Defining a range and just copying the data in those cells is a lot data than the thousands of columns in the sheet and I doubt your spreadsheet uses all of them.

Also as Vitaya said it's quicker to just copy the values and you can always bulk format the whole lot afterwards if it's required.

Sub copy_rows2()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

dim c as integer
c = 10 'number of columns with data

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
lastRow = lastRow * 4

For i = 1 To lastRow Step 4

 'inserts 3 rows at a time 
 ActiveSheet.Rows(i + 1 & ":" & i + 3).Insert Shift:=xlDown 

 'copy data into new rows limited to number of columns c
 Range(Cells(i + 1, 1), Cells(i + 3, c)).Value = Range(Cells(i, 1), Cells(i, c)).Value

Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

End Sub