CODEWITHSUNDEEP
vbaexcel
keewee279
keewee279

Reputation: 1654

VBA: Make simple macro run faster

I need to search two tables which change daily for certain values, then highlight the corresponding cells in grey and write the thresholds in the first column of each table.

For this I am using the following approach which works as intended.
Unfortunately, the macro needs more than one minute to complete this which to me seems very long for such an action (and this macro is only part of a larger one).

Both tables are relatively small and only contain approx. 500 resp. 100 records.

Can someone tell me how I can make this run faster or write this code more efficient ?

My code:

Sub PrepareRankRecords(varMode As String)
    Call RankRecords(varMode, 10000)
    Call RankRecords(varMode, 5000)
    Call RankRecords(varMode, 2000)
    Call RankRecords(varMode, 1500)
    Call RankRecords(varMode, 1000)
    Call RankRecords(varMode, 500)
End Sub

Sub RankRecords(varMode As String, varRank As Integer)
    Dim cell As Range, varRange As Range

    If varMode = "DSP" Then
         ' table AE:AJ
        Application.StatusBar = "90 % - Ranking table AE:AJ"
        DoEvents
        Set varRange = Range("$AI$3", Cells(Rows.Count, "AI").End(xlUp)).Cells
    Else
         ' table X:AC
        Application.StatusBar = "60 % - Ranking table X:AC"
        DoEvents
        Set varRange = Range("$AB$3", Cells(Rows.Count, "AB").End(xlUp)).Cells
    End If
    With Worksheets(4)
        For Each cell In varRange
            If cell.Offset(0, -3).Value <> "" Then
                If cell.Value < varRank Then
                    cell.Offset(0, -4).Value = "< " & Format(varRank, "#,##0")
                    .Range(Cells(cell.Row, cell.Column - 4), Cells(cell.Row, cell.Column + 1)). _
Interior.Color = RGB(217, 217, 217)
                    .Range(Cells(cell.Row, cell.Column - 4), Cells(cell.Row, cell.Column + 1)). _
Font.Bold = True
                    Exit For
                End If
            Else
                Exit For
            End If
        Next
    End With
End Sub

Many thanks in advance for any help with this, Mike

Upvotes: 0

Views: 160

Answers (2)

Vityata
Vityata

Reputation: 43565

Usually what I would do is the following:

Sub PrepareRankRecords(varMode As String)
    call Onstart
    Call RankRecords(varMode, 10000)
    Call RankRecords(varMode, 5000)
    'other code
    call OnEnd
End Sub

Public Sub OnEnd()

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False

    Application.StatusBar = False

End Sub

Public Sub OnStart()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlAutomatic
    ThisWorkbook.Date1904 = False

    ActiveWindow.View = xlNormalView

End Sub

You may inspect the OnStart/OnEnd and remove the parts that you consider useless.

Upvotes: 1

avb
avb

Reputation: 1753

I would replace Cells(cell.Row, cell.Column - 4) with cell(1, -3).

Also I would replace consecutive calling of RankRecords with using Select Case inside your main loop to do all things in one pass.

Upvotes: 0

Related Questions