Tam*_*ose 2 excel performance vba
我正在比较工作簿中的工作表。该工作簿有两张名为 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
对工作表单元格的任何引用都很慢。当你循环执行时，这会显着增加。最好的速度提升来自于限制这些工作表引用。
一种好方法是复制变体数组中的数据，然后循环这些数据，构建一个新的变体数组并保留数据。然后一口气将新数组放在旧数组上。
使用 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
原来的：
一种好方法是复制变体数组中的数据，然后循环这些数据，构建对单元格的引用以便稍后删除。然后一次性删除。
其他一般提示：
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