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
