VBA：让简单的宏运行得更快

Question

我需要在两个每天变化的表格中搜索某些值，然后以灰色突出显示相应的单元格并在每个表格的第一列中写下阈值。

为此，我正在使用以下按预期工作的方法。
不幸的是，宏需要超过一分钟才能完成，在我看来，这样的操作似乎很长（而且这个宏只是一个更大的宏的一部分）。

两个表都比较小，只包含大约。 500 分别。 100 条记录。

有人可以告诉我怎样才能让它运行得更快或更高效地编写这段代码？

我的代码：

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

非常感谢您在此提供的任何帮助， 迈克

Answer 1

通常我会做以下事情：

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

您可以检查 OnStart/OnEnd 并删除您认为无用的部分。

Answer 2

我会将Cells(cell.Row, cell.Column - 4) 替换为cell(1, -3)。

另外，我将在主循环中使用 Select Case 替换连续调用 RankRecords 以一次性完成所有操作。