Home » excel » excel – Speed up copying data from one sheet to another

excel – Speed up copying data from one sheet to another

Posted by: admin April 23, 2020 Leave a comment

Questions:

On one sheet I have data from column A to column L.

I have a macro that, given user input, searches the rows, and then copy and pastes that row into a different (initally blank) sheet. The search will then continue, each time copying and pasting.

Sometimes this involves copying & pasting 500 rows. Excel starts struggling at around 400 rows, is very slow and often crashes.

I have read Slow VBA macro writing in cells but I am not sure if it applies.

Would creating a collection of the row numbers resulting from my search and then looping through and copying & pasting the corresponding row be any quicker than copying and pasting the row as soon as it has been ‘found’ (this is how it currently works)?

Can I speed up this process of copying & pasting a large amount of rows?

nextblankrow=worksheets("findings").Range("A"&rows.count).End(xlup).row+1
Sheets("data").cells(J,1).EntireRow.copy sheets("findings").cells(nextblankrow,1)

In the above code, the first line finds the next empty row in the “findings” sheet.
Then the second line copies the row in the “data” sheet which has been found to match the user input into the “findings” sheet.

After this, it goes back to the search until it has got to the end of data in the “data” sheet. But I have determined that it is the copying that is causing slowness and crashing.

How to&Answers:

Speed Up Copy/Paste Range

In case you didn’t know, turning off (False) of Application.ScreenUpdating and especially Application.Calculation will increase the execution speed of your code, too.

Union Range Version

Sub CopyRangeToSheetUnion()

  ' Source
  Const cVntSrc As Variant = "Sheet1"      ' Source Worksheet Name/Index
  Const cStrSrcRange As String = "A1:J10"  ' Source Range
  Const cIntColumn As Integer = 1          ' Source Search Column

  ' Target
  Const cStrTgtCell As String = "A1"   ' Target First Cell Range
  Const cVntTgt As Variant = "Sheet2"  ' Target Worksheet Name/Index

  Dim rngU As Range      ' Union Range
  Dim i As Long          ' Source Range Row Counter

  With Worksheets(cVntSrc).Range(cStrSrcRange)

    ' Loop through each cell in column cIntColumn of Source Range and copy
    ' to Union Range if condition is met.
    For i = 1 To .Rows.Count
      If .Cells.Cells(i, cIntColumn).Value <> "" Then
        If Not rngU Is Nothing Then
          Set rngU = Union(rngU, .Cells(i, cIntColumn))
         Else
          Set rngU = .Cells(i, cIntColumn)
        End If
      End If
    Next

  End With

  ' Copy entire rows from Union range to Target Range.
  If Not rngU Is Nothing Then
    rngU.EntireRow.Copy Worksheets(cVntTgt).Range(cStrTgtCell)
    Set rngU = Nothing
  End If

End Sub

Array Version

Here is a sample with a condition which copies every row that doesn’t have an empty cell in column “A” (I’ll be posting a sample with a condition using the Union method shortly).

Sub CopyRangeToSheetArray()

  ' Source
  Const cVntSrc As Variant = "Sheet1"      ' Source Worksheet Name/Index
  Const cStrSrcRange As String = "A1:J10"  ' Source Range
  Const cIntColumn As Integer = 1          ' Source Search Column

  ' Target
  Const cStrTgtCell As String = "A1"   ' Target First Cell Range
  Const cVntTgt As Variant = "Sheet2"  ' Target Worksheet Name/Index

  Dim vntSrc As Variant  ' Source Array
  Dim vntTgt As Variant  ' Target Array
  Dim i As Long          ' Source Array Row Counter
  Dim j As Integer       ' Source/Target Array Column Counter
  Dim k As Long          ' Target Array Column Count/Counter

  ' Paste the Source Range into Source Array.
  vntSrc = Worksheets(cVntSrc).Range(cStrSrcRange)

  ' Count the number of rows that meet the condition.
  For i = 1 To UBound(vntSrc)
    If vntSrc(i, cIntColumn) <> "" Then
      k = k + 1
    End If
  Next

  ' Resize Target Array.
  ReDim vntTgt(1 To k, 1 To UBound(vntSrc, 2))

  ' Reset Target Array Column Counter
  k = 0

  ' Write from Source to Target Array.
  For i = 1 To UBound(vntSrc)
    If vntSrc(i, cIntColumn) <> "" Then
      k = k + 1
      For j = 1 To UBound(vntSrc, 2)
        vntTgt(k, j) = vntSrc(i, j)
      Next
    End If
  Next

  ' Paste Target Array into Target Worksheet
  Worksheets(cVntTgt).Range(cStrTgtCell) _
      .Resize(UBound(vntTgt), UBound(vntTgt, 2)) = vntTgt

End Sub

Appetizer

Here is a sample for copying a specific range without any condition. You can change (increase) the values in the constants section, play with it to see how fast it is and to better understand the concept. I’ll be posting a sample with a condition shortly.

Sub CopyRangeToSheet()

  ' Source
  Const cVntSrc As Variant = "Sheet1"      ' Source Worksheet Name/Index
  Const cStrSrcRange As String = "A1:J10"  ' Source Range

  ' Target
  Const cStrTgtCell As String = "A1"   ' Target First Cell Range
  Const cVntTgt As Variant = "Sheet2"  ' Target Worksheet Name/Index

  Dim vntSrc As Variant  ' Source Array

  With Worksheets(cVntSrc)
    vntSrc = .Range(cStrSrcRange)
    Worksheets(cVntTgt).Range(cStrTgtCell) _
        .Resize(UBound(vntSrc), UBound(vntSrc, 2)) = vntSrc
  End With

End Sub

Answer:

I Found that first sortig the whole table and then using a filter before copying the whole bulk is much faster than to copy each row.

'Number of rows
lonYMax = Sheets("YourTable").Cells(Rows.Count, 1).End(xlUp).Row

ActiveSheet.Range("$A$1:$AE$" & lonYMax).AutoFilter Field:=24, Criteria1:= _
   "Your filter"
Range("A1:AE" & lonYMax).Select
'Copy whole section
Selection.Copy
Windows("OtherWorkbook.xlsx").Activate
Range("A1").Select
'Insert bulk
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close