提高FOR循环的性能 [英] Improving the performance of FOR loop

查看：159
本文介绍了提高FOR循环的性能的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

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



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



我想优化两个 FOR NEXT 循环

  Dim RESULT As String 
 
 iPRE = ActiveWorkbook.Worksheets（PRE）。范围（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 
 
如果iPRE& iPOST然后
 MsgBoxPRE和POST表中的行数不一样，宏退出
退出子
 
 Else 
 iRows = iPRE 
结束如果
 
'优化性能
 
 Application.ScreenUpdating = False 
 
 EventState = Application.EnableEvents 
 Application.EnableEvents = False 
 
 CalcState = Application.Calculation 
 Application.Calculation = xlCalculationManual 
 
 PageBreakState = ActiveSheet.DisplayPageBreaks 
 ActiveSheet.DisplayPageBreaks = False 
 
对于iCntr = iRows到2步骤-1 
对于y = 1到20 
如果工作表（PRE）。单元格（iCntr，y）工作表（POST）。单元格（iCntr，y）然后
 RESULT =DeleteN
退出
 Else 
 RESULT =DeleteY
 End If 
下一个y 
 
如果RESULT =DeleteY然后
工作表（PRE）。Rows（iCntr）.Delete 
工作表（POST）。Rows iCntr）.Delete 
 End If 
 Next iCntr 
 
'还原optmizing行
 
 ActiveSheet.DisplayPageBreaks = PageBreakState 
 Application.Calculation = CalcState 
 Application.EnableEvents = EventState 
 Application.ScreenUpdating = True 
 
 End Sub


解决方案

任何对工作表单元格的引用都很慢。当循环中这样做时，这会大大增加。最好的速度增长将来自限制这些工作表引用。



一个好的方法是复制Variant数组中的数据，并循环遍历这些，构建一个新的Variant Array，要保存的数据。然后将新阵列一次性放在旧位置上。



使用20万行，20列，50％文本，50％数字的测试数据集，删除17万行：此代码在我的硬件上运行约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 
 
设置wsPre = ActiveWorkbook.Worksheets（PRE）
使用wsPre 
设置rPre = .Range（.Cells（1，.Columns.Count）.End（xlToLeft），.Cells（.Rows.Count，1）.End（xlUp））
 PreDat = rPre.Value 
 iPRE = UBoun d（PreDat，1）
'MsgBox iPRE 
结束
 
设置wsPost = ActiveWorkbook.Worksheets（POST）
使用wsPost 
设置rPost = .Range（.Cells（1，.Columns.Count）.End（xlToLeft），.Cells（.Rows.Count，1）.End（xlUp））
 PostDat = rPost.Value 
 iPOST = UBound（PostDat，1）
'MsgBox iPOST 
结束
 
如果iPRE<> iPOST然后
 MsgBoxPRE和POST表中的行数不一样，宏退出
 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 
错误GoTo EH：
'优化性能
 
 Application.ScreenUpdating = False 
 EventState = Application.EnableEvents 
 Application.EnableEvents = False 
 
 CalcState = Application.Calculation 
 Application.Calculation = xlCalculationManual 
 
 PageBreakState = ActiveSheet.DisplayPageBreaks 
 ActiveSheet.DisplayPageBreaks = False 
 
 
 T1 = GetTickCount 
对于y = 1到UBound（PreDat，2）
 PreDelDat（1，y）= PreDat（1，y）
 PostDelDat（1，y）= PostDat（1，y）
下一个
 
n = 2 
对于iCntr = 2 To UBound（PreDat， 1）
 ResDelete = True 
对于y = 1到UBound（PreDat，2）
如果PreDat（iCntr，y） PostDat（iCntr，y）然后
 ResDelete = False 
退出
结束如果
下一个y 
 
如果没有ResDelete然后
对于y = 1到UBound（PreDat，2）
 PreDelDat（n，y）= PreDat（iCntr，y）
 PostDelDat（n，y）= PostDat（iCntr，y）
下一个
n = n + 1 
 End If 
 Next iCntr 
 T2 = GetTickCount 
 Debug.PrintCompare Done in：，T2  -  T1 
 Debug.Print要删除的行：，n  -  1 
 
 rPre = PreDelDat 
 rPost = PostDelDat 
 
 T3 = GetTickCount 
 Debug.PrintDelete Done In： ，T3  -  T1 
清理：
'恢复optmizing行
在错误恢复下一步
 ActiveSheet.DisplayPageBreaks = PageBreakState 
 Application.Calculation = CalcState 
应用程序.EnableEvents = EventState 
 Application.ScreenUpdating = True 
退出子
 EH：
'Han dle错误在这里
 Debug.Assert False 
简历
 Err.Clear 
恢复清理
结束Sub





原始：



一个好的方法是复制数据在变量数组中，并循环遍历，构建对单元格的引用以稍后删除。然后一次删除。



其他一般提示：




  • 声明
    • $ 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范围
 
 Dim PreDat As Variant，PostDat As Variant 
 
使用ActiveWorkbook.Worksheets（PRE）
 PreDat = .Range（.Cells（1，20） ，.Cells（.Rows.Count，1）.End（xlUp））。值
 iPRE = UBound（PreDat，1）
'MsgBox iPRE 
结束
 
使用ActiveWorkbook.Works heets（POST）
 PostDat = .Range（.Cells（1，20），.Cells（.Rows.Count，1）.End（xlUp））值
 iPOST = UBound（PostDat ，1）
'MsgBox iPOST 
结束
 
如果iPRE<> iPOST然后
 MsgBoxPRE和POST表中的行数不一样，宏退出
 Exit Sub 
 End If 
 iRows = iPRE 
 
错误GoTo EH：
'优化性能
 
 Application.ScreenUpdating = False 
 EventState = Application.EnableEvents 
 Application.EnableEvents = False 
 
 CalcState = Application.Calculation 
 Application.Calculation = xlCalculationManual 
 
 PageBreakState = ActiveSheet.DisplayPageBreaks 
 ActiveSheet.DisplayPageBreaks = False 
 
对于iCntr = 2 To UBound（PreDat，1）
 ResDelete = True 
对于y = 1到20 
如果PreDat（iCntr，y） PostDat（iCntr，y）然后
 ResDelete = False 
退出
结束如果
下一个y 
 
如果ResDelete然后
如果rPreDelete是没有，然后
设置rPreDelete =工作表（PRE）。行（iCntr）
设置rPostDelete =工作表（POST）。行（iCntr）
 Else 
设置rPreDelete = Application.Union（rPreDelete，Worksheets（PRE）。Rows（iCntr））
设置rPostDelete = Application.Union（rPostDelete，Worksheets（POST）。Rows（iCntr））
 End If 
结束如果
下一步iCntr 
如果不是rPreDelete是没有，然后
 rPreDelete.Delete 
 rPostDelete.Delete 
结束如果
 
清理：
'还原optmizing行
在错误恢复下一步
 ActiveSheet.DisplayPageBreaks = PageBreakState 
 Application.Calculation = CalcState 
 Application.EnableEvents = EventState 
 Application.ScreenUpdating = True 
退出子
 EH：
'处理错误
 
恢复清理
结束子


I am comparing sheets in a workbook. The workbook has two sheets named PRE and POST with the same 19 columns in each. The number of rows varies every day but are same for the two sheets on a particular day. The macro compares each row in the PRE sheet to the corresponding row in the POST sheet and deletes the rows in both sheets if they are identical.

I have the usually suggested methods of improving performance like screen updating set to FALSE etc.

I want to optimize the two FOR NEXT loops.

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

解决方案

Any references to a worksheet cells is slow. This adds up dramatically when you do it in a loop. The best speed increase will come from limiting these worksheet references.

One good way is to copy the data in Variant Arrays, and loop over these, building a new Variant Array with the data to be kept. Then place the new array over the old in one go in one go.

Using a test data set of 200,000 rows, 20 columns, 50% text, 50% numbers, deleting 170,000 rows: this code runs in about 30s on my hardware

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

Original:

One good way is to copy the data in Variant Arrays, and loop over these, building a reference to cells to delete later. Then do the delete in one go.

Other general tips:

  • Declare all variables
  • Use more appropriate data types (Long, Boolean)
  • Use End(xlUp) to avoid failing at unexpected blanks (unless you want to stop at the first blank)

Refactored code:

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

这篇关于提高FOR循环的性能的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文
相关文章
Office最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆