VBA – Speed up Copy and Paste macro

[whazzzzzupp17]

Hello, I wrote a macro to copy and paste data from one sheet to another sheet, however, it takes a good 30 seconds.

Is there any tips someone can teach me on how I can speed this up?

    Sub CopyMacro()
     ' Declare variables
     Dim r1 As Range
     Dim r2 As Range
     Dim r3 As Range
     Dim r4 As Range
     Dim r5 As Range
     Dim rng As Range
     Dim LastRow As Long
    
     ' Disable updates to increase performance.
     Application.ScreenUpdating = False
     Application.Calculation = xlCalculationManual
    
     'Set ranges to copy from and paste to
     Set r1 = Sheet17.Range("Q16:T1500")
     Set r2 = Sheet1.Range("B2") ' Paste location 1
    
     Set r3 = Sheet17.Range("N16:N1500")
     Set r4 = Sheet1.Range("F2") ' Paste location 2
    
     Set r5 = Sheet1.Range("G2:G1500") ' Location to paste formula
    
     ' Delete previous copied data.
     Sheet1.Range("B2:G1500").ClearContents
    
     ' Clear filters from Scoreboard Sheet.
     On Error Resume Next
     Sheet17.ShowAllData ' Show data on Sheet17 if table is filter before copying.
     On Error GoTo 0
    
     r1.Copy ' Copy and paste range 1 to range 2
     r2.PasteSpecial Paste:=xlPasteValues
    
     r3.Copy ' Copy and paste range 3 to range 4.
     r4.PasteSpecial Paste:=xlPasteValues
    
     ' Select blanks cells within Project column and delete rows.
     On Error Resume Next
     Set rng = Range("Table19[[Project]]").SpecialCells(xlCellTypeBlanks)
     On Error GoTo 0
     If Not rng Is Nothing Then
     rng.Delete Shift:=xlUp
     End If
    
     ' Sort table columns
     With Sheet1.Sort
     .SortFields.Add Key:=Range("B1"), Order:=xlAscending 'Project
     .SortFields.Add Key:=Range("F1"), Order:=xlAscending 'State
     .SortFields.Add Key:=Range("C1"), Order:=xlAscending 'City
     .SortFields.Add Key:=Range("E1"), Order:=xlAscending 'Number
     .SortFields.Add Key:=Range("D1"), Order:=xlAscending 'Number 2
     .SetRange Range("A1:G1500")
     .Header = xlYes
     .Apply
     End With
    
    
     ' Copy and paste formula to last column
     r5.FormulaR1C1 = "=IF([@Project]<>R[-1]C[-5],WORKDAY.INTL(RC[-1],0,0),WORKDAY.INTL(MAX(R[-1]C,RC[-1]),IF(COUNTIF(R1C7:R[-1]C,WORKDAY.INTL(MAX(R[-1]C,RC[-1]),0,1))>=2,1,0),,Holidays))"
    
     ' Re-enable updating.
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    
    End Sub

 

[aRandomHelper]

I suspect it should be the deletion slowing you down. Try this amendment

    Sub CopyMacro()
     ' Declare variables
     Dim r1 As Range
     Dim r2 As Range
     Dim r3 As Range
     Dim r4 As Range
     Dim r5 As Range
     Dim rng As Range
     Dim LastRow As Long
    
     ' Disable updates to increase performance.
     Application.ScreenUpdating = False
     Application.Calculation = xlCalculationManual
    
     'Set ranges to copy from and paste to
     Set r1 = Sheet17.Range("Q16:T1500")
     Set r2 = Sheet1.Range("B2") ' Paste location 1
    
     Set r3 = Sheet17.Range("N16:N1500")
     Set r4 = Sheet1.Range("F2") ' Paste location 2
    
     Set r5 = Sheet1.Range("G2:G1500") ' Location to paste formula
    
     ' Delete previous copied data.
     Sheet1.Range("B2:G1500").ClearContents
    
     ' Clear filters from Scoreboard Sheet.
     On Error Resume Next
     Sheet17.ShowAllData ' Show data on Sheet17 if table is filter before copying.
     On Error GoTo 0
    
     r1.Copy ' Copy and paste range 1 to range 2
     r2.PasteSpecial Paste:=xlPasteValues
    
     r3.Copy ' Copy and paste range 3 to range 4.
     r4.PasteSpecial Paste:=xlPasteValues
    
     ' Sort table before deleting
     With Sheet1.Sort
     .SortFields.Add Key:=Range("B1"), Order:=xlAscending 'Project
     .SetRange Range("A1:G1500")
     .Header = xlYes
     .Apply
     End With

     ' Select blanks cells within Project column and delete rows.
     On Error Resume Next
     Set rng = Range("Table19[[Project]]").SpecialCells(xlCellTypeBlanks)
     On Error GoTo 0
     If Not rng Is Nothing Then
     rng.Delete Shift:=xlUp
     End If
    
     ' Sort table columns
     With Sheet1.Sort
     .SortFields.Add Key:=Range("B1"), Order:=xlAscending 'Project
     .SortFields.Add Key:=Range("F1"), Order:=xlAscending 'State
     .SortFields.Add Key:=Range("C1"), Order:=xlAscending 'City
     .SortFields.Add Key:=Range("E1"), Order:=xlAscending 'Number
     .SortFields.Add Key:=Range("D1"), Order:=xlAscending 'Number 2
     .SetRange Range("A1:G1500")
     .Header = xlYes
     .Apply
     End With
    
    
     ' Copy and paste formula to last column
     r5.FormulaR1C1 = "=IF([@Project]<>R[-1]C[-5],WORKDAY.INTL(RC[-1],0,0),WORKDAY.INTL(MAX(R[-1]C,RC[-1]),IF(COUNTIF(R1C7:R[-1]C,WORKDAY.INTL(MAX(R[-1]C,RC[-1]),0,1))>=2,1,0),,Holidays))"
    
     ' Re-enable updating.
     Application.Calculation = xlCalculationAutomatic
     Application.ScreenUpdating = True
    
    End Sub

 

[whazzzzzupp17]

Thanks! It helped a little bit. Still really slow, but I guess I will live with it.