Trying to speed up a macro that runs over 50,000 lines ! I have two ways of performing the same vba macro
Sub deleteCommonValue()
Dim aRow, bRow As Long
Dim colB_MoreFirst, colB_LessFirst, colB_Second, colC_MoreFirst, colC_LessFirst, colC_Second As Integer
Dim colD_First, colD_Second As Integer
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
aRow = 2
bRow = 3
colB_MoreFirst = Range("B" & aRow).Value + 0.05
colB_LessFirst = Range("B" & aRow).Value - 0.05
colB_Second = Range("B" & bRow).Value
colC_MoreFirst = Range("C" & aRow).Value + 0.05
colC_LessFirst = Range("C" & aRow).Value - 0.05
colC_Second = Range("C" & bRow).Value
colD_First = Range("D" & aRow).Value
colD_Second = Range("D" & bRow).Value
Do
If colB_Second <= colB_MoreFirst And colB_Second >= colB_LessFirst Then
If colC_Second <= colC_MoreFirst And colC_Second >= colC_LessFirst Then
If colD_Second = colD_First Or colD_Second > colD_First Then
Range(bRow & ":" & bRow).Delete
'bRow delete, assign new value to bRow
colB_Second = Range("B" & bRow).Value
colC_Second = Range("C" & bRow).Value
colD_Second = Range("D" & bRow).Value
'-----------------------------------------------------
Else
Range(aRow & ":" & aRow).Delete
bRow = aRow + 1
'aRow value deleted, assign new value to aRow and bRow
colB_MoreFirst = Range("B" & aRow).Value + 0.05
colB_LessFirst = Range("B" & aRow).Value - 0.05
colB_Second = Range("B" & bRow).Value
colC_MoreFirst = Range("C" & aRow).Value + 0.05
colC_LessFirst = Range("C" & aRow).Value - 0.05
colC_Second = Range("C" & bRow).Value
colD_First = Range("D" & aRow).Value
colD_Second = Range("D" & bRow).Value
'-----------------------------------------------------
End If
Else
bRow = bRow + 1
'Assign new value to bRow
colB_Second = Range("B" & bRow).Value
colC_Second = Range("C" & bRow).Value
colD_Second = Range("D" & bRow).Value
'-----------------------------------------------------
End If
Else
bRow = bRow + 1
'Assign new value to bRow
colB_Second = Range("B" & bRow).Value
colC_Second = Range("C" & bRow).Value
colD_Second = Range("D" & bRow).Value
'-----------------------------------------------------
End If
If IsEmpty(Range("D" & bRow).Value) = True Then
aRow = aRow + 1
bRow = aRow + 1
'finish compare aRow, assign new value to aRow and bRow
colB_MoreFirst = Range("B" & aRow).Value + 0.05
colB_LessFirst = Range("B" & aRow).Value - 0.05
colB_Second = Range("B" & bRow).Value
colC_MoreFirst = Range("C" & aRow).Value + 0.05
colC_LessFirst = Range("C" & aRow).Value - 0.05
colC_Second = Range("C" & bRow).Value
colD_First = Range("D" & aRow).Value
colD_Second = Range("D" & bRow).Value
'-----------------------------------------------------
End If
Loop Until IsEmpty(Range("D" & aRow).Value) = True
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = False
End Sub
or
Sub deleteCommonValue()
Dim aRow, bRow As Long
Application.ScreenUpdating = False
aRow = 2
bRow = 3
Do
If Range("B" & bRow).Value <= (Range("B" & aRow).Value + 0.05) _
And Range("B" & bRow).Value >= (Range("B" & aRow).Value - 0.05) Then
If Range("C" & bRow).Value <= (Range("C" & aRow).Value + 0.05) _
And Range("C" & bRow).Value >= (Range("C" & aRow).Value - 0.05) Then
If Range("D" & bRow).Value = (Range("D" & aRow).Value) _
Or Range("D" & bRow).Value > (Range("D" & aRow).Value) Then
Range(bRow & ":" & bRow).Delete
Else
Range(aRow & ":" & aRow).Delete
bRow = aRow + 1
Range("A" & aRow).Select
End If
Else
bRow = bRow + 1
Range("A" & bRow).Select
End If
Else
bRow = bRow + 1
Range("A" & bRow).Select
End If
If IsEmpty(Range("D" & bRow).Value) = True Then
aRow = aRow + 1
bRow = aRow + 1
End If
Loop Until IsEmpty(Range("D" & aRow).Value) = True
End Sub
I dont know if my best option will be to split the rows into multiple sheets?
