Code taking a long time to run and causing "Not Responding" error

[stirlingmw]

Good morning I have the following code which clears the contents of one Worksheet "Project Summary" then copies and pastes certain columns of data from another worksheet "Project Master" and pastes them into "Project Summary". the problem I have is that when I run the code it causes the the program to stall producing "Not Responding" error. This error does clear after approximately 20 seconds when the code has finished running. Is there anything I can do to the code to prevent this happening and speed up the process?

Private Sub CommandButton2_Click()
Dim lastrow As Long, erow As Long
ActiveSheet.Unprotect "-------"


Application.ScreenUpdating = False
Worksheets("Project Summary").Cells(Rows.count, 1).End(xlUp).Select
Selection.ClearContents
Worksheets("Project Summary").Range("A1").Select
lastrow = Worksheets("Project Master").Cells(Rows.count, 1).End(xlUp).Row


For i = 2 To lastrow


Worksheets("Project Master").Cells(i, 1).Copy
erow = Worksheets("Project Summary").Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 1)


Worksheets("Project Master").Cells(i, 5).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 2)


Worksheets("Project Master").Cells(i, 14).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 3)


Worksheets("Project Master").Cells(i, 7).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 4)


Worksheets("Project Master").Cells(i, 10).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 5)


Worksheets("Project Master").Cells(i, 71).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 6)


Worksheets("Project Master").Cells(i, 63).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 7)


Worksheets("Project Master").Cells(i, 64).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 8)


Worksheets("Project Master").Cells(i, 46).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 9)


Worksheets("Project Master").Cells(i, 47).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 10)


Worksheets("Project Master").Cells(i, 48).Copy
Worksheets("Project Master").Paste Destination:=Worksheets("Project Summary").Cells(erow, 11)


Next i
Application.CutCopyMode = False
Range("A1").Select
ActiveSheet.Protect "-------"
Application.ScreenUpdating = True
End Sub

Thanks

Steve

 

[FormR]

Hi, how about copying each column in its entirety, instead of row by row - something like this maybe:

Private Sub CommandButton2_Click()
Dim lastrow As Long, erow As Long, i As Long
Dim cols As Variant


ActiveSheet.Unprotect "-------"


cols = Array(1, 5, 14, 7, 10, 71, 63, 64, 46, 47, 48)


Application.ScreenUpdating = False


Worksheets("Project Summary").Cells(Rows.Count, 1).End(xlUp).ClearContents
lastrow = Worksheets("Project Master").Cells(Rows.Count, 1).End(xlUp).Row
erow = Worksheets("Project Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row


For i = 0 To UBound(cols)
    With Worksheets("Project Master")
        .Range(.Cells(2, cols(i)), .Cells(lastrow, cols(i))).Copy Destination:=Worksheets("Project Summary").Cells(erow, i + 1)
    End With
Next i


Application.CutCopyMode = False
Range("A1").Select
ActiveSheet.Protect "-------"
Application.ScreenUpdating = True
End Sub

 

[dmt32]

Hi,
As you have discovered, using copy in a loop for each range can be a tad slow

if you want to re-order data to place another sheet then use an array

Following untested but see if helps

Sub CommandButton2_Click()
    Dim lastrow As Long, r As Long, c As Long
    Dim arr() As Variant
    Dim wsProjectSummary As Worksheet, wsProjectMaster As Worksheet
    
'set object variables
    Set wsProjectSummary = Worksheets("Project Summary")
    Set wsProjectMaster = Worksheets("Project Master")
    
     With wsProjectSummary
        .Unprotect "-------"
        .Cells(.Rows.Count, 1).End(xlUp).ClearContents
     End With
    
    lastrow = wsProjectMaster.Cells(Rows.Count, 1).End(xlUp).Row
    
'size array
    ReDim arr(1 To lastrow, 1 To 11)
'build array
    For r = 1 To lastrow
        i = 0
        For c = 1 To 11
        i = i + 1
        arr(r, c) = wsProjectMaster.Cells(r + 1, Choose(i, 1, 5, 14, 7, 10, 71, 63, 64, 46, 47, 48)).Value
        Next c
    Next r


'output array to range
    With wsProjectSummary
        .Cells(2, 1).Resize(UBound(arr, 1), 11).Value = arr
        .Protect "-------"
    End With


End Sub

Hope Helpful

Dave

 

[stirlingmw]

FormR
Thank you, works great, I did however have to amend the code slightly as when it was run it added new lines to the bottom of the Worksheet as opposed to replacing what was there.

I changed

Worksheets("Project Summary").Cells(Rows.Count, 1).End(xlUp).ClearContents

for

Worksheets("Project Summary").Rows("2:1000").Select
Selection.ClearContents

Thanks

Steve

 

[FormR]

Hi, that's good

FYI, you don't need to select cells to work with them and it often slows your code if you do. You can write those lines like this:

Worksheets("Project Summary").Rows("2:1000").ClearContents

I guess also as the "Projects summary" sheet always starts blank, there is really no need for the "erow" variable - you could simply hard code the row in the below line like this:

.Range(.Cells(2, cols(i)), .Cells(lastrow, cols(i))).Copy Destination:=Worksheets("Project Summary").Cells(2, i + 1)