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变量）都是如此之快，以至于您几乎无法测量它。

因此，我的建议是将工作表中的所有数据读入内存，将其中的行“相乘”，然后将所有内容一次写回。

下面的代码示例读取2维数组中的数据，并将其复制到4倍大的2nd数组中。这第二个数组写回到工作表。我用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

Answer 2

如果您对格式不感兴趣，而仅对值感兴趣，可能是最快的方法：

Sub TestMe()

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

End Sub

Answer 3

FunThomas是对的，这应该是最快的方法，但是如果这不是一种选择，那么不复制整个行会更快。

定义一个范围并仅复制这些单元格中的数据比工作表中数千列的数据要多得多，我怀疑您的电子表格会使用所有这些数据。

正如Vitaya所说的那样，仅复制值会更快，并且如果需要的话，您以后总是可以批量格式化整个批次。

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

VBA快速复制行

3 个答案: