VBA快速复制行 [英] VBA copy rows fast

问题描述

我必须处理具有5000行的文件，对于每一行，我必须再插入3行并在这些新行中复制内容（此后将有更多步骤）。
我的宏工作正常，但是复制内容的过程确实很慢，我确定有一个更好的解决方案，有什么想法吗？

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

非常感谢

推荐答案

谈到速度：

在VBA中访问Excel数据很慢，插入行（或列）的速度很慢，而内存中的所有操作（VBA变量）都非常快，以至于几乎无法测量它。

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.

下面的代码示例读取二维数组中的数据，然后将其复制到4倍大的第二数组中。这第二个数组写回到工作表。我用1000行进行了测试，执行时间为0。

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

这篇关于VBA快速复制行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！