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

Question

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

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

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

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

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

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

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

Answer 1

对于矩形块：

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

很快。

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

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

编辑#1：

范围到范围方法甚至不需要中间数组：

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

这真的是一样的：

ary=r1.Value
r2.value=ary

除了ary 是隐式的。

Answer 2

我尝试了 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

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

Answer 3

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

我的代码如下所示：

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

手写代码，如有错误请见谅。

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

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

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

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

Answer 4

永远不要尝试遍历包含许多行的大数据集。尽量按列复制范围。

Dim lRow As Long
lRow = Sheets("Source").Range("A100000").End(xlUp).Row
Sheets("Target").Range("A1:D" & lRow).Value = 
Sheets("Source").Range("G1:J" & lRow).Value

Answer 5

Sub CopyPaste(rPaste As Range, rCopy As Range, Optional val As Boolean = True)
 Dim p As Long
 Dim r As Long
 Dim c As Long
 Dim aCalculation As XlCalculation
 aCalculation = XlCalc()
 On Error GoTo Finally
Try:
 If rPaste.Count = 1 Then
  r = rPaste.Areas(1).Row - rCopy.Areas(1).Row
  c = rPaste.Areas(1).Column - rCopy.Areas(1).Column
  For p = 1 To rCopy.Areas.Count
   With rCopy.Areas(p)
    Set rPaste = Union(rPaste, Cells(.Row, .Column).Offset(r, c).Resize(.Rows.Count, .Columns.Count))
   End With
  Next 'p
 End If
 For p = 1 To rPaste.Areas.Count
  With Cells(rCopy.Areas(p).Row, rCopy.Areas(p).Column).Resize(Application.min(rCopy.Areas(p).Rows.Count, rPaste.Areas(p).Rows.Count), _
                                                               Application.min(rCopy.Areas(p).Columns.Count, rPaste.Areas(p).Columns.Count))
   If val Then
    If 1 Then 'faster
     rPaste.Areas(p) = .Value
    Else
     .Copy
     Cells(rPaste.Areas(p).Row, rPaste.Areas(p).Column).PasteSpecial paste:=xlPasteValues
    End If
   Else
    .Copy Destination:= _
    Cells(rPaste.Areas(p).Row, rPaste.Areas(p).Column)
   End If 'val
  End With
 Next 'p
Finally:
 XlCalc aCalculation
End Sub

Function XlCalc(Optional aCalculation As Long = 0) As XlCalculation
 Dim bCutCopyMode As Boolean
 Dim bCleared As Boolean
 bCutCopyMode = Application.CutCopyMode
 XlCalc = Application.Calculation
 Application.EnableEvents = aCalculation <> 0
 Application.ScreenUpdating = aCalculation <> 0
 'assignment to Application.Calculation clears the clipboard
 If aCalculation = 0 Then
  bCleared = XlCalc <> xlCalculationManual
  If bCleared Then Application.Calculation = xlCalculationManual
 Else
  If aCalculation = xlCalculationAutomatic Then Application.Calculate
  bCleared = XlCalc <> aCalculation
  If bCleared Then Application.Calculation = aCalculation
 End If
 If Not bCleared Then Exit Function
 If Not bCutCopyMode Then Exit Function
 If Selection Is Nothing Then Exit Function
 Selection.Copy 'restore clipboard
End Function

Answer 6

禁用 ScreenUpdating 在我的机器上增加了 8 毫秒 禁用计算会增加 6

两者之间没有明显差异（以微秒为单位！） .Range(cstrColPreviousPrice & clngFirstRow & ":" & cstrColPreviousPrice & glngLastRow).Value2 = .Range(cstrColPrice & clngFirstRow & ":" & cstrColPrice & glngLastRow).Value2

和

.Range(cstrColPreviousPrice & clngFirstRow & ":" & cstrColPreviousPrice & glngLastRow).Value2 = Application.Transpose(gavarPrice())