0

I have a large data set that I need to do some manipulations on that includes a copy/paste operation.

The only code I can get to work is shown below. This code takes a long time to run (several seconds for just a hundred rows).

Is there a more efficient way to perform this operation (e.g. do the copy and paste behind the curtains so at least the user interface is not constantly being updated but still keep the user alerted to the status of what is going on).

For r = 2 To lastRow
    dataSheet.Select
    Cells.Range(Cells(r, 1), Cells(r, 2)).Select
    Selection.Copy
    Sheets("lab_pivot").Select
    Cells(currentRow, 1).Select
    ActiveSheet.Paste
    Application.StatusBar = r & " of " & lastRow
    currentRow = currentRow + 1
Next r

--- EDIT------------------------------------

Something like the following is a big improvement (I fixed the ":=" from the previous edit and now it works).

Set labSheet = ActiveSheet
' ITERATE OVER THE ROWS
currentRow = 1
lastRow = getLastRow(dataSheet)
For r = 2 To lastRow
    With dataSheet
        .Range(.Cells(r, 1), .Cells(r, 2)).Copy Destination := labSheet.Cells(currentRow, 1)
    End With
    Application.StatusBar = r & " of " & lastRow
    currentRow = currentRow + 1
Next r
John
  • 3,458
  • 4
  • 33
  • 54
  • 7
    You might benefit from reading [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). – Pᴇʜ Jun 23 '21 at 14:20
  • 7
    `dataSheet.Range("A2:B" & lastRow).Copy Sheets("lab_pivot").Cells(currentRow, 1)` – GSerg Jun 23 '21 at 14:24
  • @John This line replaces your entire loop, not goes inside it. – GSerg Jun 23 '21 at 22:09

1 Answers1

1

Copy a Range

  • This illustrates how you can rewrite the code and each time make it more efficient.
  • There is also a duration (on my machine) of each code for a thousand rows supplied, which is showing that only the last two improvements are acceptable.
  • How will you show hundreds of numbers on the status bar in a split second anyway? Just forget about using the status bar.
Option Explicit

Sub CopyInitial() ' 48s
   
    Const sfRow As Long = 2 ' Source First Row
    Const dfRow As Long = 1 ' Destination First Row
    
    Dim slRow As Long ' Source Last Row
    slRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Dim dcRow As Long ' Destination Current Row
    dcRow = dfRow
    
    Dim r As Long ' Source Current Row
    
    For r = sfRow To slRow
        Sheet1.Select
        Range(Cells(r, "A"), Cells(r, "B")).Select
        Selection.Copy
        Sheet2.Select
        Cells(dcRow, "A").Select
        ActiveSheet.Paste
        Application.StatusBar = r & " of " & slRow
        dcRow = dcRow + 1
    Next r

End Sub

Sub CopyNoStatusBar() ' 40s
    
    Const sfRow As Long = 2 ' Source First Row
    Const dfRow As Long = 1 ' Destination First Row
    
    Dim slRow As Long ' Source Last Row
    slRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Dim dcRow As Long ' Destination Current Row
    dcRow = dfRow
    
    Dim r As Long ' Source Current Row
    
    For r = sfRow To slRow
        Sheet1.Select
        Range(Cells(r, "A"), Cells(r, "B")).Select
        Selection.Copy
        Sheet2.Select
        Cells(dcRow, "A").Select
        ActiveSheet.Paste
        dcRow = dcRow + 1
    Next r

End Sub

Sub CopyNoSelect() ' 19s
    
    Const sfRow As Long = 2 ' Source First Row
    Const dfRow As Long = 1 ' Destination First Row
    
    Dim slRow As Long ' Source Last Row
    slRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Dim dcRow As Long ' Destination Current Row
    dcRow = dfRow
    
    Dim r As Long ' Source Current Row
    
    For r = sfRow To slRow
        Sheet1.Range(Sheet1.Cells(r, "A"), Sheet1.Cells(r, "B")).Copy _
            Sheet2.Cells(dcRow, "A")
        dcRow = dcRow + 1
    Next r

End Sub

Sub CopyNoScreenUpdating() ' 13s
    
    Const sfRow As Long = 2 ' Source First Row
    Const dfRow As Long = 1 ' Destination First Row
    
    Dim slRow As Long ' Source Last Row
    slRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Dim dcRow As Long ' Destination Current Row
    dcRow = dfRow
    
    Dim r As Long ' Source Current Row
    
    Application.ScreenUpdating = False
    
    For r = sfRow To slRow
        Sheet1.Range(Sheet1.Cells(r, "A"), Sheet1.Cells(r, "B")).Copy _
            Sheet2.Cells(dcRow, "A")
        dcRow = dcRow + 1
    Next r

    Application.ScreenUpdating = True

End Sub

Sub CopyNoLoop() ' 0.05s
    
    Const sfRow As Long = 2 ' Source First Row
    Const dfRow As Long = 1 ' Destination First Row
    
    Dim slRow As Long ' Source Last Row
    slRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Sheet1.Range(Sheet1.Cells(sfRow, "A"), Sheet1.Cells(slRow, "B")).Copy _
            Sheet2.Cells(dfRow, "A")

End Sub

Sub CopyByAssignment() ' 0.017s (but values only)
    
    Const sfRow As Long = 2 ' Source First Row
    Const dfRow As Long = 1 ' Destination First Row
    
    Dim slRow As Long ' Source Last Row
    slRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
    
    Dim srg As Range
    Set srg = Sheet1.Range(Sheet1.Cells(sfRow, "A"), Sheet1.Cells(slRow, "B"))
    
    Dim drg As Range
    Set drg = Sheet2.Cells(dfRow, "A") _
        .Resize(srg.Rows.Count, srg.Columns.Count)
            
    drg.Value = srg.Value

End Sub
VBasic2008
  • 44,888
  • 5
  • 17
  • 28