Excel VBA Optimize Cycle

Question

I apologize if already exist a similar question, but if yes, I not found.

I'm new to programming in VBA and still do not know much of it, now I'm trying to run a function that will verify if in a column "B" are repeated velores and if exist will check in a column "C" where the highest value, copying the lowest to another table and deleting it.

The code already does all this however need to run in tables of 65 000 lines and it takes a long time, never got for running these tables, because even when I run in tables with 5000 or 10000 lines takes approximately 6 to 15 minutes.

My question is if there is any way to optimize the cycle that I'm using, it will be better to use a For Each or maintain the Do While Loop?

Here is the code I am using:

Function Copy()

    Worksheets("Sheet1").Range("A1:AQ1").Copy _
    Destination:=Worksheets("Sheet2").Range("A1")

    Dim lRow As Long
    Dim lRow2 As Long
    Dim Row As Long
    Dim countA As Long
    Dim countB As Long
    Dim t As Double

    lRow = 5000
    Row = 2
    countA = 0
    countB = 0

    Application.ScreenUpdating = False 
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    Application.EnableEvents = False
    Application.DisplayStatusBar = False

    ActiveSheet.DisplayPageBreaks = False
    lRow2 = lRow - 1
    t = Timer

     Do While lRow > 2


            If (Cells.Item(lRow, "B") <> Cells.Item(lRow2, "B")) Then 

                lRow = lRow - 1
                lRow2 = lRow - 1

            Else

                If (Cells.Item(lRow, "C") > Cells.Item(lRow2, "C")) Then 

                    Sheets("Sheet1").Rows(lRow2).Copy Sheets("Sheet2").Rows(Row)
                    Rows(lRow2).Delete 
                    lRow = lRow - 1
                    Row = Row + 1
                    countA = countA + 1


                Else

                    Sheets("Sheet1").Rows(lRow).Copy Sheets("Sheet2").Rows(Row)
                    Rows(lRow).Delete 
                    lRow = lRow - 1
                    Row = Row + 1
                    countB = countB + 1

                End If

                lRow2 = lRow2 - 1

           End If

    Loop

    Application.DisplayStatusBar = True
    ActiveWindow.View = ViewMode
    Application.ScreenUpdating = False 
    MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t) / 60

End Function

Answer 1

Everything i could think of has already been mentioned above, however this code snippet might help someone out, it's the least you could do to make a macro faster (in case no interaction is required during runtime of the macro)

Run Optimize(True) at the start of your code, Optimize(False) at the end.

'Toggles unnecessary excel features
Sub Optimize(start As Boolean) 
    On Error Resume Next
    With Application
        .ScreenUpdating = Not (start)
        .DisplayStatusBar = Not (start)
        .EnableEvents = Not (start)
        If start Then
            .Calculation = xlCalculationManual
        Else
            .Calculation = xlCalculationAutomatic
        End If
    End With
    On Error GoTo 0
End Sub

Answer 2

Typically it's faster to perform a single delete at the end of the loop.

Untested:

Function Copy()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim lRow As Long, Row As Long, viewmode
    Dim countA As Long, countB As Long
    Dim t As Double, rw As Range, rngDel As Range

    lRow = 5000
    Row = 2
    countA = 0
    countB = 0

    Set shtSrc = Worksheets("Sheet1")
    Set shtDest = Worksheets("Sheet2")

    shtSrc.Range("A1:AQ1").Copy Destination:=shtDest.Range("A1")

    Application.ScreenUpdating = False
    viewmode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    Application.EnableEvents = False
    Application.DisplayStatusBar = False

    ActiveSheet.DisplayPageBreaks = False

    t = Timer

     Do While lRow > 2

            Set rw = shtSrc.Rows(lRow)

            If (rw.Cells(2) = rw.Cells(2).Offset(-1, 0)) Then

                If (rw.Cells(3) > rw.Cells(3).Offset(-1, 0)) Then
                    rw.Offset(-1, 0).Copy shtDest.Rows(Row)
                    AddToRange rngDel, rw.Offset(-1, 0)
                    countA = countA + 1
                Else
                    rw.Copy shtDest.Rows(Row)
                    AddToRange rngDel, rw
                    countB = countB + 1
                End If

                Row = Row + 1

           End If

           lRow = lRow - 1

    Loop

    'anything to delete?
    If Not rngDel Is Nothing Then
        rngDel.Delete
    End If

    Application.DisplayStatusBar = True
    ActiveWindow.View = viewmode
    Application.ScreenUpdating = False
    MsgBox "A = " & countA & " B = " & countB & "Time (minutes): " & (Timer - t) / 60

End Function

'utility sub for building up a range
Sub AddToRange(rngTot, rng)
    If rngTot Is Nothing Then
        Set rngTot = rng
    Else
        Set rngTot = Application.Union(rng, rngTot)
    End If
End Sub