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.

Answer 1

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

Answer 2

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.

Answer 3

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:

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

2. After that, copied complete sheet data to new sheet

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

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

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

Answer 4

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