如何让我的代码运行得更快？将单元格从一张纸复制到另一张纸

I've created this code which is copying all values from 'Sheet1' - starting in A2 cell to the first empty row of column 1 in Sheet2.

我创建了这个代码，它复制了'Sheet1'中的所有值 - 从A2单元格开始到Sheet2中第1列的第一个空行。

In case that more cells are needed to be copied, it is running quite long. Is there a possibility to make it run faster?

如果需要复制更多单元格，它将运行很长时间。是否有可能让它运行得更快？

Thanks

谢谢

Sub CopyCells()

Dim CopyRow As Long

CopyRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row 'find last first             empty cell in destination sheet
'Sheets("Sheet1").Range("A2").Copy Destination:=Sheets("Sheet2").Range("A" & CopyRow + 1)

Call turn_on_off(False)

For I = 2 To Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Sheet1").Range("A" & I).Copy Destination:=Sheets("Sheet2").Range("A" & CopyRow + I - 1)

Next I
Call turn_on_off(True)
End Sub

Public Sub turn_on_off(mode As Boolean)

With Application
    .Calculation = IIf(mode = True, xlCalculationAutomatic, xlCalculationManual)
    .ScreenUpdating = mode
End With

End Sub

1 个解决方案

#1

There is no need to use loop:

没有必要使用循环：

Sub CopyCells()
    Dim CopyRow As Long
    Dim lastrow As Long
    Dim sh1 As Worksheet, sh2 As Worksheet

    Call turn_on_off(False)

    Set sh1 = ThisWorkbook.Worksheets("Sheet1")
    Set sh2 = ThisWorkbook.Worksheets("Sheet2")

    lastrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row
    CopyRow = sh2.Cells(Rows.Count, 1).End(xlUp).Row

    sh2.Range("A" & CopyRow + 1).Resize(lastrow - 1).Value = _
        sh1.Range("A2:A" & lastrow).Value

    Call turn_on_off(True)
End Sub

Range.Value=Range.Value is much faster then Copy/Paste, however it copies only values (without formatting). If you need to copy formatting as well, change Range.Value=Range.Value part to:

Range.Value = Range.Value比复制/粘贴快得多，但它只复制值（没有格式化）。如果您还需要复制格式，请将Range.Value = Range.Value部分更改为：

sh1.Range("A2:A" & lastrow).Copy Destination:=sh2.Range("A" & CopyRow + 1)

#1