performance - 提高 FOR 循环的性能

Question

我正在比较工作簿中的工作表。该工作簿有两张名为 PRE 和 POST 的工作表，每张工作表都有相同的 19 列。行数每天都不同，但特定一天的两张表的行数相同。该宏将 PRE 工作表中的每一行与 POST 工作表中的相应行进行比较，如果两个工作表中的行相同，则删除它们。

我通常建议提高性能的方法，例如将屏幕更新设置为 FALSE 等。

我想优化两个 FOR NEXT 循环。

Dim RESULT As String

iPRE = ActiveWorkbook.Worksheets("PRE").Range("A1", Worksheets("PRE").Range("A1").End(xlDown)).Rows.Count
'MsgBox iPRE
iPOST = ActiveWorkbook.Worksheets("POST").Range("A1", Worksheets("POST").Range("A1").End(xlDown)).Rows.Count
'MsgBox iPOST

If iPRE <> iPOST Then
    MsgBox "The number of rows in PRE and POST sheets are not the same. The macro quits"
    Exit Sub

Else
    iRows = iPRE
End If

 'Optimize Performance

    Application.ScreenUpdating = False

    EventState = Application.EnableEvents
    Application.EnableEvents = False

    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual

    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False

    For iCntr = iRows To 2 Step -1
        For y = 1 To 20
            If Worksheets("PRE").Cells(iCntr, y) <> Worksheets("POST").Cells(iCntr, y) Then
                RESULT = "DeleteN"
                Exit For
            Else
                RESULT = "DeleteY"
            End If
        Next y

        If RESULT = "DeleteY" Then
            Worksheets("PRE").Rows(iCntr).Delete
            Worksheets("POST").Rows(iCntr).Delete
        End If
    Next iCntr

    'Revert optmizing lines

    ActiveSheet.DisplayPageBreaks = PageBreakState
    Application.Calculation = CalcState
    Application.EnableEvents = EventState
    Application.ScreenUpdating = True

End Sub

Answer 1

对工作表单元格的任何引用都很慢。当你循环执行时，这会显着增加。最好的速度提升来自于限制这些工作表引用。

一个好的方法是复制变体数组中的数据，然后循环这些数据，构建一个新的变体数组并保留数据。然后一次性将新数组放在旧数组上。

使用 200,000 行、20 列、50% 文本、50% 数字的测试数据集，删除 170,000 行:此代码在我的硬件上运行大约 30 秒

Sub Mine2()
    Dim T1 As Long, T2 As Long, T3 As Long

    Dim ResDelete As Boolean
    Dim iPRE As Long, iPOST As Long
    Dim EventState  As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
    Dim iCntr As Long, y As Long, iRows As Long
    Dim rPre As Range, rPost As Range

    Dim PreDat As Variant, PostDat As Variant, PreDelDat As Variant, PostDelDat As Variant

    Dim n As Long
    Dim wsPre As Worksheet, wsPost As Worksheet

    Set wsPre = ActiveWorkbook.Worksheets("PRE")
    With wsPre
        Set rPre = .Range(.Cells(1, .Columns.Count).End(xlToLeft), .Cells(.Rows.Count, 1).End(xlUp))
        PreDat = rPre.Value
        iPRE = UBound(PreDat, 1)
        'MsgBox iPRE
    End With

    Set wsPost = ActiveWorkbook.Worksheets("POST")
    With wsPost
        Set rPost = .Range(.Cells(1, .Columns.Count).End(xlToLeft), .Cells(.Rows.Count, 1).End(xlUp))
        PostDat = rPost.Value
        iPOST = UBound(PostDat, 1)
        'MsgBox iPOST
    End With

    If iPRE <> iPOST Then
        MsgBox "The number of rows in PRE and POST sheets are not the same. The macro quits"
        Exit Sub
    End If
    iRows = iPRE


    ReDim PreDelDat(1 To UBound(PreDat, 1), 1 To UBound(PreDat, 2))
    ReDim PostDelDat(1 To UBound(PostDat, 1), 1 To UBound(PostDat, 2))
    n = 1
    On Error GoTo EH:
 'Optimize Performance

    Application.ScreenUpdating = False
    EventState = Application.EnableEvents
    Application.EnableEvents = False

    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual

    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False


    T1 = GetTickCount
    For y = 1 To UBound(PreDat, 2)
        PreDelDat(1, y) = PreDat(1, y)
        PostDelDat(1, y) = PostDat(1, y)
    Next

    n = 2
    For iCntr = 2 To UBound(PreDat, 1)
        ResDelete = True
        For y = 1 To UBound(PreDat, 2)
            If PreDat(iCntr, y) <> PostDat(iCntr, y) Then
                ResDelete = False
                Exit For
            End If
        Next y

        If Not ResDelete Then
            For y = 1 To UBound(PreDat, 2)
                PreDelDat(n, y) = PreDat(iCntr, y)
                PostDelDat(n, y) = PostDat(iCntr, y)
            Next
            n = n + 1
        End If
    Next iCntr
    T2 = GetTickCount
    Debug.Print "Compare Done in:", T2 - T1
    Debug.Print "Rows to delete:", n - 1

    rPre = PreDelDat
    rPost = PostDelDat

    T3 = GetTickCount
    Debug.Print "Delete Done In:", T3 - T1
CleanUp:
    'Revert optmizing lines
    On Error Resume Next
    ActiveSheet.DisplayPageBreaks = PageBreakState
    Application.Calculation = CalcState
    Application.EnableEvents = EventState
    Application.ScreenUpdating = True
Exit Sub
EH:
    ' Handle Errors here
    Debug.Assert False
    Resume
    Err.Clear
    Resume CleanUp
End Sub

<小时/>

原文:

一个好的方法是复制变体数组中的数据，然后循环这些数据，构建对单元格的引用以便稍后删除。然后一次性删除。

其他一般提示:

• 声明所有变量
• 使用更合适的数据类型(长整型、 bool 型)
• 使用 End(xlUp) 避免因意外空白而失败(除非您想要在第一个空白处停止)

重构代码:

Sub Demo()
    Dim ResDelete As Boolean
    Dim iPRE As Long, iPOST As Long
    Dim EventState  As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
    Dim iCntr As Long, y As Long, iRows As Long
    Dim rPreDelete As Range, rPostDelete As Range

    Dim PreDat As Variant, PostDat As Variant

    With ActiveWorkbook.Worksheets("PRE")
        PreDat = .Range(.Cells(1, 20), .Cells(.Rows.Count, 1).End(xlUp)).Value
        iPRE = UBound(PreDat, 1)
        'MsgBox iPRE
    End With

    With ActiveWorkbook.Worksheets("POST")
        PostDat = .Range(.Cells(1, 20), .Cells(.Rows.Count, 1).End(xlUp)).Value
        iPOST = UBound(PostDat, 1)
        'MsgBox iPOST
    End With

    If iPRE <> iPOST Then
        MsgBox "The number of rows in PRE and POST sheets are not the same. The macro quits"
        Exit Sub
    End If
    iRows = iPRE

    On Error GoTo EH:
 'Optimize Performance

    Application.ScreenUpdating = False
    EventState = Application.EnableEvents
    Application.EnableEvents = False

    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual

    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False

    For iCntr = 2 To UBound(PreDat, 1)
        ResDelete = True
        For y = 1 To 20
            If PreDat(iCntr, y) <> PostDat(iCntr, y) Then
                ResDelete = False
                Exit For
            End If
        Next y

        If ResDelete Then
            If rPreDelete Is Nothing Then
                Set rPreDelete = Worksheets("PRE").Rows(iCntr)
                Set rPostDelete = Worksheets("POST").Rows(iCntr)
            Else
                Set rPreDelete = Application.Union(rPreDelete, Worksheets("PRE").Rows(iCntr))
                Set rPostDelete = Application.Union(rPostDelete, Worksheets("POST").Rows(iCntr))
            End If
        End If
    Next iCntr
    If Not rPreDelete Is Nothing Then
        rPreDelete.Delete
        rPostDelete.Delete
    End If

CleanUp:
    'Revert optmizing lines
    On Error Resume Next
    ActiveSheet.DisplayPageBreaks = PageBreakState
    Application.Calculation = CalcState
    Application.EnableEvents = EventState
    Application.ScreenUpdating = True
Exit Sub
EH:
    ' Handle Errors here

    Resume CleanUp
End Sub