在 Excel VBA 中复制大量值的最快方法

Fastest Method to Copy Large Number of Values in Excel VBA

提问by ma_YYC

Quite simply, I am wondering what the fastest method of copying cell values from one sheet to another is.

很简单，我想知道将单元格值从一张纸复制到另一张纸的最快方法是什么。

Generally, I'll loop through the cells by column and/or row and use a line such as:

通常，我会按列和/或行遍历单元格并使用如下一行：

Worksheets("Sheet1").Cells(i,j).Value = Worksheets("Sheet1").Cells(y,z).Value

In other cases where my ranges are not consecutive rows/columns (e.g. I want to avoid overwriting cells that already contain data) I'll either have a conditional inside the loop, or I'll fill an array(s) with row & column numbers that I want to cycle through, and then cycle through the array elements. For example:

在我的范围不是连续的行/列的其他情况下（例如，我想避免覆盖已经包含数据的单元格）我要么在循环内有一个条件，要么用行和列填充数组我想循环的数字，然后循环遍历数组元素。例如：

Worksheets("Sheet1").Cells(row1(i),col1(j)).Value = Worksheets("Sheet2").Cells(row2(y),col2(z)).Value

Would it be faster to define ranges using the cells I want to copy and the destination cells, then do a Range.Copyand Range.Pasteoperation? Is it possible to define a range using an array without having to loop through it anyway? Or will it be faster anyway to loop through an array to define a range and then copy-pasting the range instead of equating the cell values by looping?

使用我要复制的单元格和目标单元格定义范围，然后执行Range.Copy和Range.Paste操作会更快吗？是否可以使用数组定义一个范围而不必遍历它？或者无论如何循环遍历数组以定义范围然后复制粘贴范围而不是通过循环来等同单元格值会更快吗？

I feel like it might not be possible to copy and paste ranges like this at all (i.e. they would need to be cells continuous through a rectangular array and pasted into a rectangular array of the same size). That being said, I would think that it's possible to equate the elements of two ranges without looping through each cell and equating the values.

我觉得可能根本不可能复制和粘贴这样的范围（即它们需要是通过矩形阵列连续的单元格并粘贴到相同大小的矩形阵列中）。话虽如此，我认为可以在不循环遍历每个单元格并使值相等的情况下将两个范围的元素相等。

回答by Gary's Student

For a rectangular block this:

对于矩形块：

Sub qwerty()
    Dim r1 As Range, r2 As Range

    Set r1 = Sheets("Sheet1").Range("A1:Z1000")
    Set r2 = Sheets("Sheet2").Range("A1")

    r1.Copy r2
End Sub

is pretty quick.

很快。

For a non-contiguousrange on the activesheet, I would use a loop:

对于活动表上的非连续范围，我将使用循环：

Sub qwerty2()
    Dim r1 As Range, r2 As Range

    For Each r1 In Selection
        r1.Copy Sheets("Sheet2").Range(r1.Address)
    Next r1
End Sub

EDIT#1:

编辑#1：

The range-to-range method does not even require an intermediate array:

range-to-range 方法甚至不需要中间数组：

Sub ytrewq()
    Dim r1 As Range, r2 As Range

    Set r1 = Sheets("Sheet1").Range("A1:Z1000")
    Set r2 = Sheets("Sheet2").Range("A1:Z1000")

    r2 = r1
End Sub

this is really the same as:

这实际上与以下内容相同：

ary=r1.Value
r2.value=ary

except the aryis implicit.

除了ary是隐式的。

回答by Patrick Lepelletier

i tried 4 methods, and the NOT obvious (to me) came out:

我尝试了 4 种方法，但结果并不明显（对我来说）：

Option Explicit

Sub testCopy_speed()

Dim R1 As Range, r2 As Range
Set R1 = ThisWorkbook.Sheets(1).Range("A1:Z1000")
Set r2 = ThisWorkbook.Sheets(2).Range("A1:Z1000")

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With


Dim t As Single
Dim i&, data(), Rg As Range
ReDim data(R1.Rows.Count, R1.Columns.Count)

For Each Rg In R1.Cells: Rg = Rnd()*100: Next Rg

R1.ClearContents
R1.ClearFormats

r2.ClearContents
r2.ClearFormats


'For Each Rg In R1.Cells: 'if you do this too often , you'll get an error
'    With Rg
'        .Value2 = Rnd() * 100
'        .Interior.Color = Rnd() * 65535
'        '.Font.Color = Rnd() * 65535
'    End With
'Next Rg


t = Timer

For i = 1 To 100
    'r2.Value2 = R1.Value2 '1,71 sec
    'R1.Copy r2 '0.74 sec  <<<<   Winer , but see NOTE.
    'data = R1.Value2: r2.Value2 = data '1.78 sec
    'For Each Rg In R1.Cells: r2.Cells(Rg.Row, Rg.Column).Value2 = Rg.Value2: Next Rg '54 seconds !!
Next i

Erase data
Set R1 = Nothing
Set r2 = Nothing
Set Rg = Nothing

Debug.Print Timer - t

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Note : i wasn't happy with these results so i tested some more, and if R1 contains many different formating , the R1.copy R2method will take 10 seconds. So in this case R2=R1would be better by far (6 times faster).

注意：我对这些结果不满意，所以我测试了更多，如果 R1 包含许多不同的格式，该R1.copy R2方法将需要 10 秒。所以在这种情况下R2=R1会更好（快 6 倍）。

回答by MattD

I found this thread looking to speed up transfer of 72 cells from one sheet to another (a data storage sheet to a data entry sheet).

我发现这个线程希望加快 72 个单元格从一个工作表到另一个工作表（数据存储表到数据输入表）的传输。

My code looked like this:

我的代码如下所示：

t(7)=timer*1000
Dim datasht As Worksheet
Set datasht = WB2.Worksheets("Equipment-Data")
With WB2.Worksheets("Equipment")
 .Range("D2").Value = datasht.Cells(datarow, 1)
 .Range("D3").Value = datasht.Cells(datarow, 2)
 .Range("I7").Value = datasht.Cells(datarow, 3)
 ...
 t(8)=timer*1000     
 ...
 .Range("G51").Value = datasht.Cells(datarow,72)
End With
t(9)=timer*1000

Code typed by hand, please forgive any typos.

手工输入的代码，请原谅任何错别字。

Getting from t(7) to t(9) took around 600ms. As an aside, I switched from using Application.WorksheetFunction.Vlookup72 times to determining the appropriate row in the data table with a single datarow=.Cells.Find(...)and it made no perceivable impact in execution time.

从 t(7) 到 t(9) 大约需要 600 毫秒。顺便说一句，我从使用Application.WorksheetFunction.Vlookup72 次切换到使用单个datarow=.Cells.Find(...)确定数据表中的适当行，并且它对执行时间没有明显影响。

I added a timer in the middle and confirmed that each half was taking roughly 300ms which made sense but wanted to make sure there wasn't a particular cell causing issues.

我在中间添加了一个计时器，并确认每一半大约需要 300 毫秒，这是有道理的，但要确保没有特定的单元格导致问题。

Since most of the time only 1 or a small handful of cells have changed I added a check to see if the data is different before writing and the Sub now runs in about 4ms.

由于大多数情况下只有 1 个或少数几个单元格发生了变化，因此我添加了一个检查，以查看写入前的数据是否不同，现在 Sub 的运行时间约为 4 毫秒。

If .Range("D2").Formula <> datasht.Cells(datarow, 1).Formula Then .Range("D2").Value = datasht.Cells(datarow, 1)