Slow macro, usaully crashes my PC. Need help optimizing it

[leopilot]

So I have created this MACRO for work, to ensure everything is getting charged right. Well I would like it to run through pretty much the entire database data for 2 years, I can not get it to last that long. I can copy the data to a separate spreadsheet and run the macro in chunks, but I would like to not have to do that. So as of now it just runs down the list and if it see the something wrong it highlights it. And at the end it sorts the table by color, putting the colored cells on top, showing me the changes that need to be made. Now keep in mind... this is a VERY LARGE spreadsheet, that is connected to a database. There is literally 177091 rows. So if it is possible Great, if not oh well.


Sub incorrect()

Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
Application.DisplayAlerts = False

'Application.DisplayStatusBar = True
' makes sure that the statusbar is visible
'Application.StatusBar = "****PLEASE WAIT WHILE CLEANUP MACRO RUNS - THIS WILL TAKE A FEW MINUTES"




With ActiveSheet

Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
' Insert your code here.
'



If ActiveCell.Value >= 200 And ActiveCell.Value <= 299 Then
ActiveCell.Offset(0, 3).Activate
If ActiveCell.Value = "0160A1" Then
ActiveCell.Offset(1, -3).Select
ElseIf ActiveCell.Value = "0160RH" Then
ActiveCell.Offset(1, -3).Select
ElseIf ActiveCell.Value <> "0160A1" <> "0160RH" Then ActiveCell.Offset(0, -3).Range("D1,A1").Select

With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

ActiveCell.Offset(1, -3).Select
End If
End If



If ActiveCell.Value >= 400 And ActiveCell.Value <= 499 Then
ActiveCell.Offset(0, 3).Activate
If ActiveCell.Value = "0152A1" Then
ActiveCell.Offset(1, -3).Select
ElseIf ActiveCell.Value <> "0152A1" Then ActiveCell.Offset(0, -3).Range("D1,A1").Select

With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

ActiveCell.Offset(1, -3).Select
End If
End If

If ActiveCell.Value >= 500 And ActiveCell.Value <= 599 Then
ActiveCell.Offset(0, 3).Activate
If ActiveCell.Value = "0162A1" Then
ActiveCell.Offset(1, -3).Select
ElseIf ActiveCell.Value <> "0162A1" Then ActiveCell.Offset(0, -3).Range("D1,A1").Select

With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

ActiveCell.Offset(1, -3).Select
End If

End If

'ActiveCell.Offset(1, 0).Select

If ActiveCell.Value >= 100 And ActiveCell.Value <= 199 Then
ActiveCell.Offset(0, 3).Activate
If ActiveCell.Value = "0161A1" Then
ActiveCell.Offset(1, -3).Select
ElseIf ActiveCell.Value <> "0161A1" Then ActiveCell.Offset(0, -3).Range("D1,A1").Select

With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

ActiveCell.Offset(1, -3).Select
End If
End If

If ActiveCell.Value >= 900 And ActiveCell.Value <= 999 Then
ActiveCell.Offset(0, 3).Activate
If ActiveCell.Value = "0167AZ" Then
ActiveCell.Offset(1, -3).Select
ElseIf ActiveCell.Value <> "0167AZ" Then ActiveCell.Offset(0, -3).Range("D1,A1").Select

With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

ActiveCell.Offset(1, -3).Select
End If
End If

Loop



ActiveWorkbook.Worksheets("Employee Look Up").ListObjects( _
"Table_Query_from_budget_1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Employee Look Up").ListObjects( _
"Table_Query_from_budget_1").Sort.SortFields.Add(Range( _
"Table_Query_from_budget_1[[#Headers],[#Data],[COSTCNTR]]"), xlSortOnCellColor _
, xlAscending, , xlSortTextAsNumbers).SortOnValue.Color = RGB(255, 255, 0)
With ActiveWorkbook.Worksheets("Employee Look Up").ListObjects( _
"Table_Query_from_budget_1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With



End With

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True


'Application.StatusBar = False
' gives control of the statusbar back to the programme
'MsgBox "The Cleanup macro has finished.", vbInformation + vbOKOnly, "Macro Completed"


End Sub

 

[Jerry Sullivan]

Hi leopilot,

There's no need to use Activate, ActiveCell, Select, and Selection to do this kind of processing.
Their use makes the code less efficient, but more importantly it makes the logic of the code very hard to follow.

It's more efficient to simply reference Cells and other objects directly using Index numbers or other references.

There are usually more efficient approaches than can eliminate stepping through each Row or Cell. Because the code is time-consuming to interpret- I haven't digested it and I don't know if those approaches would work in lieu of this process.

For the purpose you describe, you might consider adding a helper column and copy down a formula that flags rows that don't meet the conditions that are required.