VBA Time Sheet and dealing with Lunch breaks - excel

Question

I have the workbook below that shows clock in and out each day for each employee and shop. I was able to find the cell and if they are late after 8:00 am then it will debug.print that the employee was late. The problem I have now is that sometimes the employee goes on a lunch break and its reading the second time clocked in as if he was late. I would like to print notes on the sheet that will tell me for example "Nathan was late on Monday, 8:47:43 AM" and if he left during the day and came back. For example "Trent left Monday on 12:54 PM and came back on 1:28 PM". I am just having trouble reading through multiple times on the same day. The below code is what I have so far. Any ideas?
Sheet :
Sub TestFindAll()
Dim SearchRange As Range
Dim FindWhat As Variant
Dim FoundCells As Range
Dim FoundCell As Range
Dim LastRowA As Long, LastRowJ As Long
Dim WS1 As Worksheet
Set WS1 = ThisWorkbook.Worksheets("DailyTimeSheet")
LastRowJ = WS1.Range("J" & WS1.Rows.Count).End(xlUp).Row
Debug.Print LastRowJ
Dim firstAddress As String
With WS1
Dim tbl As ListObject: Set tbl = .Range("DailyTime").ListObject
Set SearchRange = tbl.ListColumns("EmployeeName").Range
End With
For t = 2 To LastRowJ
FindWhat = WS1.Range("J" & t)
Set FoundCells = SearchRange.Find(What:=FindWhat, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
If Not FoundCells Is Nothing Then
firstAddress = FoundCells.Address
Debug.Print "Found " & FoundCells.Value & " " & FoundCells.Offset(0, 2).Value
Do
If Not FoundCells.Offset(0, 2).Value = "Sat" And FoundCells.Offset(0, 5).Value < TimeValue("18:00:00") Then
Debug.Print FoundCells.Value & " left early on " & FoundCells.Offset(0, 2) & " at " & TimeValue(Format(FoundCells.Offset(0, 5).Value, "hh:mm:ss"))
End If
Set FoundCells = SearchRange.FindNext(FoundCells)
' Debug.Print "Found " & FoundCells.Value & " " & FoundCells.Offset(0, 2)
Loop While Not FoundCells Is Nothing And FoundCells.Address <> firstAddress
End If
Next
End Sub

Answer 1

Use a Dictionary Object with names as key to identify the first in or last out time of the day.
Option Explicit
Sub macro()
Dim lastrow As Long, r As Long, dt As String
Dim dict As Object, key, n As Long, c As Range
Set dict = CreateObject("Scripting.Dictionary")
With Sheet1 'ThisWorkbook.Worksheets("DailyTimeSheet")
.Cells.Interior.Pattern = xlNone
lastrow = .Cells(.Rows.Count, "J").End(xlUp).Row
' check in times
For Each c In .Range("J2:J" & lastrow).Cells
dt = Format(c.Offset(, 2), "yyyy-mm-dd")
key = Trim(c.Value)
' initialise
If Not dict.exists(key) Then
dict.Add key, "0000-00-00"
End If
' is this first for the day
If dict(key) <> dt Then
If c.Offset(, 2).Value <> "Sat" And _
c.Offset(, 4) > TimeValue("08:00:00") Then
c.Offset(, 4).Interior.Color = RGB(255, 255, 0)
n = n + 1
End If
End If
dict(key) = dt ' store
Next
' reverse scan to check out times
dict.RemoveAll
For r = lastrow To 2 Step -1
Set c = .Cells(r, "J")
dt = Format(c.Offset(, 2), "yyyy-mm-dd")
key = Trim(c.Value)
' initialise
If Not dict.exists(key) Then
dict.Add key, "0000-00-00"
End If
'is the last for the day
If dict(key) <> dt Then
If c.Offset(, 2).Value <> "Sat" And _
(c.Offset(, 5) < TimeValue("18:00:00")) Then
c.Offset(, 5).Interior.Color = RGB(255, 255, 0)
n = n + 1
End If
End If
dict(key) = dt ' store
Next
MsgBox n & " cells highlighted", vbInformation
End With
End Sub