VBA Time Sheet and dealing with Lunch breaks

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

user_12704593 · Answer

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

VBA Time Sheet and dealing with Lunch breaks

1 Answers