Prevent a macro from freezing / crashing / turning white the Excel window? - excel

Question

At work I am working on a macro/UserForm in Excel for someone. It's worked great on spreadsheets with 15k rows, but takes about 10 minutes to run, while Excel appears to be frozen (not responding). We've tried to run it on a 250k row sheet for about 8 hours and it never completed.
Is there a way to make it more effecient, or at least allow the user to see view its progress without Excel being locked up?
About the Macro
Users are asigned tasks, and arn't supposed to be assigned the same one within 365 days. There are 47 Columens and 250k Rows of users. Rows are sorted by username, create date, task. The macro goes row by row to first make sure its the same user, and then find instances of a task being asigned within the 365 day window, and flagging the row red. Then it checks the next row against the initial to make sure its also not within 365 days.
After reading a few dozens other posts, I'm not sure if this is the most effecient way of doing it. Iif you see anyway to make my code more efficient that would be greatly appreciated!
Sub highlight_newer_dates_v2()
Dim i As Long, j As Long
Dim lastRow As Long
Dim AccountNo As String, SpecialtyTo As String, CreateDate1 As Date, CreateDate2 As Date
Dim lastNonRedRow As Long
lastRow = Cells(Rows.Count, "I").End(xlUp).Row
lastNonRedRow = 0
For i = 2 To lastRow
AccountNo = Cells(i, 9).Value
SpecialtyTo = Cells(i, 13).Value
CreateDate1 = Cells(i, 5).Value
If Cells(i, 9).Interior.Color = RGB(255, 0, 0) Then
If lastNonRedRow = 0 Then
For j = i - 1 To 2 Step -1
If Cells(j, 9).Interior.Color <> RGB(255, 0, 0) Then
lastNonRedRow = j
Exit For
End If
Next j
End If
If lastNonRedRow <> 0 Then
CreateDate1 = Cells(lastNonRedRow, 5).Value
End If
Else
lastNonRedRow = i
End If
For j = i + 1 To lastRow
If Cells(j, 9).Value = AccountNo And Cells(j, 13).Value = SpecialtyTo Then
CreateDate2 = Cells(j, 5).Value
If Abs(CreateDate2 - CreateDate1) <= 365 Then
If CreateDate2 > CreateDate1 Then
Rows(j).Interior.Color = RGB(255, 0, 0)
Else
Rows(i).Interior.Color = RGB(255, 0, 0)
End If
End If
End If
Next j
Next i
End Sub
I've tried doing a loop to make it more effecient but couldn't get it to work properly.

Answer 1

Looping through row by row in vba is going to be inefficient. If I am understanding your problem correctly, you should 1. sort by date 2. sort by task 3 sort by user 4. use the formulas below. You would have to add even more columns if you might have more than 3 sequences, but its a pattern. You could also have vba sort by these values, put in the formulas, past the any true column as values and then sort back to your original order.
SEQUNCE
=COUNTIFS($A$5:A5,A5,$B$5:B5,B5)
2nd too close to 1st
=IF(AND(D6=2,(C6-C5)<365),1,0)
3rd too close to 2nd
=IF(AND(D7=3,(C7-C6)<365,E6=0),1,0)
ANY TRUE
=MAX(E5:F5)

Answer 2

Process 15,000 rows in a few seconds, 250,000 in < 1 minute.
Option Explicit
Sub highlight_newer_dates_v4()
Const COLS = 47
Dim ws As Worksheet
Dim dictTask, k, colDates As Collection
Dim bRed() As Boolean
Dim lastrow As Long, i As Long, j As Long
Dim n As Long, r As Long, r1 As Long, r2 As Long
Dim dt As Date, dt1 As Date, dt2 As Date
Dim task As String, accno As String
Dim t0 As Single
' store task and dates for one account
Set dictTask = CreateObject("Scripting.Dictionary")
' specify your sheet here
Set ws = ThisWorkbook.Sheets("Testdata")
'Call testData(ws, 250000)
' process data sheet
t0 = Timer
Application.ScreenUpdating = False
With ws
lastrow = .Cells(.Rows.Count, "I").End(xlUp).Row
ReDim bRed(1 To lastrow)
For r = 2 To lastrow
accno = Trim(.Cells(r, 9)) 'I
task = Trim(.Cells(r, 13)) 'M
dt = CDate(.Cells(r, 5)) 'E
' store tasks in dictionary
If Not dictTask.exists(task) Then
dictTask.Add task, New Collection
n = n + 1
End If
dictTask(task).Add Array(r, dt)
' is ths last task for person then check dates
If (.Cells(r + 1, 9)) <> accno Then
For Each k In dictTask
task = CStr(k)
Set colDates = dictTask(k)
' check interval for all permutations
' is > 365 days
For i = 1 To colDates.Count - 1
r1 = colDates(i)(0)
dt1 = colDates(i)(1)
dt = DateAdd("d", 365, dt1) '365 days later
If bRed(r1) = False Then
For j = i + 1 To colDates.Count
' color rows red if <= 365
r2 = colDates(j)(0)
dt2 = colDates(j)(1)
If bRed(r2) = False And dt2 <= dt Then
bRed(r2) = True
'.Cells(r2, 1).Resize(, COLS).Interior.Color = vbRed
.Cells(r2, 1).Interior.Color = vbYellow
End If
Next
End If
Next
Next
' clear data for next account
dictTask.RemoveAll
n = 0
End If
Next
End With
Application.ScreenUpdating = True
' result
MsgBox Format(lastrow, "0,000") & " rows scanned in " _
& Format(Timer - t0, "0.0 secs")
End Sub
Sub testData(maxrow As Long, ws As Worksheet)
Const USERS = 99
Dim TaskCount As Long
TaskCount = Int(maxrow / USERS)
Dim n As Long, t0 As Single: t0 = Timer
Application.ScreenUpdating = False
With ws
.Cells.Clear
.Columns("E:E").NumberFormat = "dd-mmm-yyyy"
.Range("E1") = "Date"
.Range("I1") = "AccNo"
.Range("M1") = "Task"
For n = 2 To maxrow
.Cells(n, 5) = DateAdd("d", 1000 * Rnd(), DateSerial(2020, 1, 1))
.Cells(n, 9) = "ID_" & Format(Rnd() * USERS + 1, "000")
.Cells(n, 13) = "Task_" & Format(Rnd() * TaskCount + 1, "0000")
Next
.Columns.AutoFit
' sort username, create date, task
With .Sort
With .SortFields
.Clear
.Add2 Key:=Range("I1:I" & maxrow), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add2 Key:=Range("E1:E" & maxrow), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add2 Key:=Range("M1:M" & maxrow), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange Range("E1:M" & maxrow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.ScreenUpdating = True
MsgBox Format(maxrow, "0,000") & " rows created in " & Format(Timer - t0, "0.0 secs")
End Sub