VBA 快速复制行

Question

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

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

非常感谢

Answer 1

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

所以我的建议是将工作表中的所有数据读入内存，“乘以”那里的行并一次写回所有内容。

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

缺点：您可能需要注意格式

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