VBA copy rows fast | 易学教程

问题

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

回答1:

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

回答2:

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

回答3:

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

来源：https://stackoverflow.com/questions/53316021/vba-copy-rows-fast

标签

excel

vba

performance

copy

rows