Fastest Method to Copy Large Number of Values in Excel VBA

Question

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.Copy and Range.Paste operation? 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?

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.

Answer 1

Disabling ScreenUpdating adds 8 ms on my machine Disabling Calculation adds 6

There is no appreciable difference (in microseconds!) between .Range(cstrColPreviousPrice & clngFirstRow & ":" & cstrColPreviousPrice & glngLastRow).Value2 = .Range(cstrColPrice & clngFirstRow & ":" & cstrColPrice & glngLastRow).Value2

And

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

Answer 2

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 3

Never try to loop over big data set with many rows. Try to copy ranges by columns as much as possible.

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 4

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).

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.Vlookup 72 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.

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.

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.

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

Answer 5

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

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 R2 method will take 10 seconds. So in this case R2=R1would be better by far (6 times faster).

Answer 6

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-contiguous range 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:

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

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 ary is implicit.