Question

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

为此，我使用以下方法按预期工作不幸的是，宏需要超过一分钟来完成这个对我来说似乎很长时间（这个宏只是更大的一部分）。

两个表都相对较小，只包含约。 500 resp。 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)。

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

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

2 个答案: