Macro Speed Improvement - vba

Question

I have written a VBA program to clean up and sort many lines of data on to separate sheets. I am quite happy with it, and it's doing exactly what I need it to do. Unfortunately it can take up to ten minutes to run, as there is around 650,000 lines of data. While stepping through the macros individually, I have determined that the macros that actually search, cut then paste data onto a separate sheet are causing the problem. Does anyone have any tips on what I can do to improve this? I will leave a macro here for you guys to take a look at.
So you know, this is what she does in order: Delete unnecessary data, remove duplicates, sort into separate sheets, then count like addresses.
I have a "RUN" macro that a "Start" button is linked to, to call all macros in the necessary order. In this macro I disable calculation and screen updating, then enable when all macros have completed.
As I mentioned here is one of my sorting macros:
Sub CorpSheet() 'Moves corporate memberships to new sheet
Dim Check As Range, r As Long, lastrow2 As Long, LastRow As Long
'Application.ScreenUpdating = False
LastRow = Worksheets("PASTE DATA HERE").UsedRange.Rows.Count
lastrow2 = Worksheets("Corporate").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = LastRow To 2 Step -1
If Range("E" & r).Value > 0 Then
Rows(r).Cut Destination:=Worksheets("Corporate") _
.Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
'Application.ScreenUpdating = True
End Sub
Any help that you can provide is appreciated!

Answer 1

Filter the sheet on ColE >0 - copy/paste the remaining rows to Corporate. Then delete the visible rows from the filtered table
Sub Faster()
Dim rngSrc As Range
Set rngSrc = Sheet1.Range("a1").CurrentRegion
rngSrc.AutoFilter Field:=5, Criteria1:=">0"
rngSrc.Copy Sheet2.Cells(Rows.Count, 1).End(xlUp)
rngSrc.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
rngSrc.AutoFilter
End Sub

Answer 2

One thing that would save a lot of time is only doing 1 copy. UNION the rows then copy them to the other sheet and delete them from the original in 1 step:
Sub CorpSheet() 'Moves corporate memberships to new sheet
Dim Check As Range, r As Long, lastrow2 As Long, LastRow As Long
Dim rng As Range
Application.ScreenUpdating = False
LastRow = Worksheets("PASTE DATA HERE").UsedRange.Rows.Count
lastrow2 = Worksheets("Corporate").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = LastRow To 2 Step -1
If Range("E" & r).Value > 0 Then
If rng Is Nothing Then
Set rng = Rows(r)
Else
Set rng = Union(rng, Rows(r))
End If
End If
Next r
rng.Copy ThisWorkbook.Sheets("Corporate").Range("A" & lastrow2 + 1)
rng.Delete xlUp
Application.ScreenUpdating = True
End Sub
Then you can clean some things up a bit, fully qualify your ranges, and remove some other unnecessary code:
Sub CorpSheet() 'Moves corporate memberships to new sheet
Dim rng As Range
Dim rw As Range
Application.ScreenUpdating = False
For Each rw In Worksheets("PASTE DATA HERE").UsedRange
If rw.Range("E1").Value > 0 Then
If rng Is Nothing Then
Set rng = rw.EntireRow
Else
Set rng = Union(rng, rw.EntireRow)
End If
End If
Next r
rng.Copy ThisWorkbook.Sheets("Corporate").Range("A" & _
Worksheets("Corporate").UsedRange.Rows.Count + 1)
rng.Delete xlUp
Application.ScreenUpdating = True
End Sub