VBA处理员工工时表解决午休打卡误判迟到及出入记录统计问题

原始问题 #

现有记录各门店员工每日上下班打卡数据的工作簿，已实现基础单元格查找逻辑：员工早8点后到岗时通过Debug.Print输出迟到提示，当前存在两个核心问题：

• 午休时段的二次返回打卡会被误判定为迟到
• 无法识别同一日期下的多条打卡记录，无法输出外出返回配对记录

期望实现效果：

• 输出迟到提示：示例 “Nathan周一迟到，到岗时间8:47:43 AM”
• 输出外出返回配对记录：示例 “Trent周一下午12:54外出，1:28返回”
• 保留原有早退判断逻辑

原始工作表参考 #

原始代码 #

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

解决方案 #

核心逻辑：先对打卡表按「员工姓名+打卡日期+打卡时间」升序排序，再按「员工+日期」为维度分组统计打卡次数，按打卡顺序判断记录类型：

1. 当日第1次打卡：判定为到岗，晚于8:00则输出迟到记录
2. 当日第2/4/6...偶数次打卡：判定为外出，暂存外出时间
3. 当日第3/5/7...奇数次（非首次）打卡：判定为返回，配对上一条外出记录输出外出返回提示
4. 当日最后1次打卡：判定为下班，早于18:00且非周六则输出早退记录

修改后代码 #

Sub ProcessAttendance()
    Dim WS1 As Worksheet
    Dim tbl As ListObject
    Dim dict As Object
    Dim arrData, arrOutput
    Dim i As Long, outputRow As Long
    Dim key As String
    Dim lastPunchTime As Date, punchCount As Integer
    
    Set WS1 = ThisWorkbook.Worksheets("DailyTimeSheet")
    Set tbl = WS1.Range("DailyTime").ListObject
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 先对表格按姓名、日期、打卡时间升序排序，保证同个员工同一天的打卡按时间顺序排列
    With tbl.Sort
        .SortFields.Clear
        .SortFields.Add Key:=tbl.ListColumns("EmployeeName").Range, Order:=xlAscending
        ' 假设日期在姓名列偏移2列（C列），字段名替换为你表中实际的日期字段名
        .SortFields.Add Key:=tbl.ListColumns("Date").Range, Order:=xlAscending
        ' 假设打卡时间在姓名列偏移4列（E列），字段名替换为你表中实际的打卡时间字段名
        .SortFields.Add Key:=tbl.ListColumns("PunchTime").Range, Order:=xlAscending
        .Header = xlYes
        .Apply
    End With
    
    ' 读取表格数据到数组，提升运行效率
    arrData = tbl.DataBodyRange.Value
    ReDim arrOutput(1 To UBound(arrData), 1 To 1) ' 输出数组，结果存在K列可自行调整
    outputRow = 1
    
    For i = 1 To UBound(arrData)
        ' 拼接分组key：员工姓名+日期，假设姓名是第1列，日期是第3列，自行调整列序号
        key = arrData(i, 1) & "|" & arrData(i, 3)
        Dim weekDayStr As String: weekDayStr = arrData(i, 3) ' 假设星期是第3列，自行调整
        Dim punchTime As Date: punchTime = arrData(i, 5) ' 假设打卡时间是第5列，自行调整
        
        If Not dict.exists(key) Then
            ' 首次打卡：判断迟到
            If punchTime > TimeValue("08:00:00") Then
                arrOutput(outputRow, 1) = arrData(i, 1) & weekDayStr & "迟到，到岗时间" & Format(punchTime, "hh:mm:ss AM/PM")
                outputRow = outputRow + 1
            End If
            ' 初始化字典：存储打卡次数、上一次打卡时间
            dict.Add key, Array(1, punchTime)
        Else
            punchCount = dict(key)(0) + 1
            lastPunchTime = dict(key)(1)
            
            If punchCount Mod 2 = 0 Then
                ' 偶数次：记录外出，暂存时间
                dict(key) = Array(punchCount, punchTime)
            Else
                ' 奇数次非首次：配对返回，输出记录
                arrOutput(outputRow, 1) = arrData(i, 1) & weekDayStr & "下午" & Format(lastPunchTime, "h:mm") & "外出，" & Format(punchTime, "h:mm") & "返回"
                outputRow = outputRow + 1
                dict(key) = Array(punchCount, punchTime)
            End If
            
            ' 判断是否是当日最后一条打卡，判断早退：假设姓名列第1，日期第3，下一行姓名日期相同则不是最后一条
            If i = UBound(arrData) Or (arrData(i + 1, 1) & "|" & arrData(i + 1, 3)) <> key Then
                If weekDayStr <> "Sat" And punchTime < TimeValue("18:00:00") Then
                    arrOutput(outputRow, 1) = arrData(i, 1) & weekDayStr & "早退，下班时间" & Format(punchTime, "hh:mm:ss")
                    outputRow = outputRow + 1
                End If
            End If
        End If
    Next i
    
    ' 输出结果到工作表K列，可自行调整位置
    WS1.Range("K2").Resize(outputRow - 1, 1).Value = arrOutput
End Sub

注意事项 #

• 代码中假设的列序号需要根据你实际表格的列顺序调整，比如日期、星期、打卡时间所在的列，修改对应的arrData(i, 列序号)即可
• 如果没有周六上班的特殊规则，可保留周六排除的判断，不需要直接删除即可

内容的提问来源于stack exchange，提问作者BalloutRacing