Speed up copying data from one sheet to another

Question

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.

Are you copying contiguous rows i.e. every row or are you checking for a condition and if it is met then you copy the row? — VBasic2008, Dec 31 '18 at 12:19
Hard to say without looking at your code. Generally, you want to do all read/write operations involving the worksheet in one go (or at least in as few batches as possible). You might find filtering (`AutoFilter`) faster than looping through individual rows. Also, something else that might be useful is building a `union` of cells/ranges, which you might be able to copy-paste in one go. Or even working with arrays might be a feasible solution. But yeah, hard to be specific without looking at the code. — chillin, Dec 31 '18 at 12:20
@VBasic2008 it is the latter, so yes unfortunately the rows being copied are not in a continuous block. — newbie23, Dec 31 '18 at 12:25
You want to restrict the copying to the used range i.e. not copy after the last used column and not copy after the last used row. When you have determined the range, in a loop you check for the condition and write each row that meets the condition to an array and when done you paste the array into a calculated (from array size) resulting range. — VBasic2008, Dec 31 '18 at 12:36
@VBasic2008 The first bit I can do (instead of entirerow I guess). Can you help me out with the array? Just a rough sketch would be highly appreciated. — newbie23, Dec 31 '18 at 12:43
Another solution might be to loop through the rows and when the condition is met, add a cell (e.g. in column A) to a Union range (rngU) and when finished copy in one go e.g. 'Sheets("data").rngU.EntireRow.copy sheets("findings").range("A1")'. — VBasic2008, Dec 31 '18 at 12:45
@VBasic2008 I have not used Union before: how would I dynamically add cells to a union? — newbie23, Dec 31 '18 at 12:56
400 rows isn't much. Try turning off screen updating, and set calculation mode to manual. — SandPiper, Dec 31 '18 at 14:33

VBasic2008 · Accepted Answer · 2022-11-19T00:08:16.137

Speed Up Copy/Paste Range

In case you didn't know, turning off Application.ScreenUpdating and setting Application.Calculation to manual will increase the execution speed of your code, too.

Union Range Version

Sub CopyRangeToSheetUnion()

    ' Source
    Const SOURCE_WORKSHEET_ID As Variant = "Sheet1"
    Const SOURCE_RANGE_ADDRESS As String = "A1:J10"
    Const SOURCE_CRITERIA_COLUMN_INDEX As Long = 1
    ' Destination
    Const DESTINATION_WORKSHEET_ID As Variant = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    
    ' Workbook
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_WORKSHEET_ID)
    Dim srg As Range: Set srg = sws.Range(SOURCE_RANGE_ADDRESS)
    
    Dim surg As Range
    Dim sCell As Range
    
    For Each sCell In srg.Columns(SOURCE_CRITERIA_COLUMN_INDEX).Cells
        If Len(CStr(sCell.Value)) > 0 Then ' the source cell is not blank
            If surg Is Nothing Then ' combine the first cell
                Set surg = sCell
            Else ' combine all but the first cell
                Set surg = Union(surg, sCell)
            End If
        'Else ' the source cell is blank; do nothing
        End If
    Next sCell
    
    If surg Is Nothing Then Exit Sub ' all cells are blank
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(DESTINATION_WORKSHEET_ID)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    ' Copy.
    
    Intersect(srg, surg.EntireRow).Copy dfCell

End Sub

Array Version

Here is a sample with a condition that copies every row that doesn't have a blank cell in column "A" (I'll be posting a sample with a condition using the Union method shortly).

Sub CopyRangeToSheetArray()

    ' Source
    Const SOURCE_WORKSHEET_ID As Variant = "Sheet1"
    Const SOURCE_RANGE_ADDRESS As String = "A1:J10"
    Const SOURCE_CRITERIA_COLUMN_INDEX As Long = 1
    ' Destination
    Const DESTINATION_WORKSHEET_ID As Variant = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    
    ' Workbook
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_WORKSHEET_ID)
    Dim srg As Range: Set srg = sws.Range(SOURCE_RANGE_ADDRESS)
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    
    ' Write the values from the Source range to a 2D one-based array.
    Dim Data() As Variant: Data = srg.Value

    ' Modify.
    
    Dim sr As Long ' Array Source Rows Counter
    Dim c As Integer ' Array Columns Counter
    Dim dr As Long ' Array Destination Rows Counter/Count
    
    ' Return the rows of condition-met data at the top of the array.
    For sr = 1 To srCount
        If Len(CStr(Data(sr, SOURCE_CRITERIA_COLUMN_INDEX))) > 0 Then ' not bl.
            dr = dr + 1
            For c = 1 To cCount
                ' Write from source row to destination row.
                Data(dr, c) = Data(sr, c)
            Next c
        'Else ' is blank; do nothing
        End If
    Next sr
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(DESTINATION_WORKSHEET_ID)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    
    ' Copy.
    
    drg.Value = Data

End Sub

An Appetizer

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

Sub CopyRangeToSheet()

    ' Source
    Const SOURCE_WORKSHEET_ID As Variant = "Sheet1"
    Const SOURCE_RANGE_ADDRESS As String = "A1:J10"
    ' Destination
    Const DESTINATION_WORKSHEET_ID As Variant = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_WORKSHEET_ID)
    Dim srg As Range: Set srg = sws.Range(SOURCE_RANGE_ADDRESS)
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(DESTINATION_WORKSHEET_ID)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
    
    ' Copy.
    drg.Value = srg.Value

End Sub

Thanks, but isn't the problem I have that my range isn't a countinuous block like "A1:J10"? — newbie23, Dec 31 '18 at 13:05
@newbie23: The was an error in the array version: Const cIntColumn As Integer = 1. It was previously set to string. Sorry. I've added the Union Range Version. — VBasic2008, Dec 31 '18 at 14:02
Thank you, I've done a union, & it's much much faster! Wish I could upvote & accept. Thanks again. — newbie23, Dec 31 '18 at 15:36
@newbie23: Didn't you know? Then go to your older questions if you wish and do so, too. — VBasic2008, Dec 31 '18 at 15:40
the last sub, CopyRangeToSheet(), is very fast and help me to solve an old problem. Thanks @VBasic2008! — cantoni, Jun 13 '21 at 13:44

score 0 · Answer 2 · answered Oct 15 '19 at 12:51

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

score 0 · Answer 3 · answered Mar 23 '21 at 19:35

Tried some methods including Range Unions, Arrays etc., to copy specific rows from one sheet to another.
all were taking time.

This methodology (a kind of not direct approach) gave me faster processing:

on 1st sheet filled condition evaluated values/strings in to a new/last column, and kept this new column cell empty for the rows, which I need to retain.
After that, copied complete sheet data to new sheet

    Range("A1:O" & nRows).Copy Destination:=Sheets(s2).Range("A1")

Now from sheet1 removed all condition filled rows

    For rw = nRows To 2 Step -1 ' from bottom to top looping
        If Cells(rw, "O") <> "" Then
            Rows(rw).EntireRow.Delete
        End If
    Next

from sheet2 removed all no condition rows

    Sheets(s2).Select
    For rw = nRows To 2 Step -1 ' from bottom to top looping
        If IsEmpty(Cells(rw, "O")) Then
            Rows(rw).EntireRow.Delete
        End If
    Next

This is definitely not a direct approach,
however vba code of direct copying rows from one sheet to another
and also using ranges and appending to it using unions is consuming high processing time! when we need to process thousands of rows.

The trick worked here is copying full data in one go, either with or without filters. and after that however delete row operation is not consuming much time.

I have mentioned here step codes only that are required to understand logic.

I will be happy to know, if any other direct method works faster, please comment.

wayfarer · Answer 4 · 2021-05-16T02:27:59.563

Not sure this is applicable, however, copying cells instead of rows makes a huge difference in one case.

I have an "TO DO List" Excel workbook with about 30 worksheets, all formatted with the same "To Do" column format. When I press a button on a control form the VBA reads through each sheet(the "Detail" sheets) and finds the "To Do" rows that have a non-blank priority column. It then copies each of those rows to an "Action" sheet at the front of the workbook, so all the Action Items from all the Detail sheets are visible in one list. There are some other features, like formatting, sorting and linking the copied Action sheet rows back to the source sheet.

I was using this code to copy from the Detail sheets to the Action sheet. With about 200 total action items it was taking up to several minutes.

   ws.Rows(n).EntireRow.Copy  '''' Detail sheet row
   aws.Rows(awsAddRow).EntireRow.PasteSpecial ''''' Action sheet row

I changed the above to this code, copying the cells column by column, it takes a few seconds.

   For cl2 = 1 To 30
      aws.Cells(awsAddRow, cl2) = ws.Cells(n, cl2)
   Next cl2

Formats and links etc seem to be all fine.

Speed up copying data from one sheet to another

4 Answers4

Speed Up Copy/Paste Range

Union Range Version

Array Version

An Appetizer

Linked