[群友求助] 海康门禁出入记录统计出勤小时！

海康门禁入出对（先入再出，且入取最后一条入，出取最早的一条出），然后根据入出对的时间计算工作时长，

海康门禁系统，全部人脸识别，模式为：先进入再外出，直接从门禁机导出原始记录。
需求描述:当前项目需要查询员工上班期间出入公司大门的记录，且计算在现场工作时长（不要计算或包含外出时间）。
人员姓名 事件时间 出/入
张三甲 2025-05-26 18:50:00 出
张三乙 2025-05-26 18:49:00 出
张三甲 2025-05-26 14:02:00 入
张三乙 2025-05-26 14:01:00 入
张三甲 2025-05-26 10:48:36 出
张三乙 2025-05-26 10:47:30 出
张三甲 2025-05-26 06:48:36 入
张三乙 2025-05-26 06:47:30 入
例如：张三甲从6:48进入匹配10:48外出，计算出时长1，然后14:02进入匹配18:50外出，计算出时长2，时长1+时长2就是张三工作的总时长。
正常每天90%的人以上都是4条数据，但是存在刷脸机器问题会有多条相近时间进入记录（取时间最晚1条）和多条相近时间外出记录（取时间早1条）
取数时相关问题:
1、每次人脸识别，可能会刷多次才能打开门，进入取最后1条，外出取最早1条。
2、根据匹配入出对来计算工作时间，减去中间外出时间。（海康平台、智慧工地，其他VBA算法只用最早的时间减去最晚时间计算时长，未减去中间外出时间）。
3、有上夜班的情况，当天晚上来上班，直到第2天早晨才回去，也根据入出对来计算工作时长，这个就跨天计算工作时长。
4、假如入出对匹配不上，提示当天工作时长为0或异常，重新匹配入出对成功或到第2天再匹配。

Sub ProcessAttendanceData()
Dim srcSheet As Worksheet, destSheet As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim empID As String, empName As String, currentDate As Date
Dim fullDateTime As Date, recordTime As Date
Dim timePairs As Collection, pair As Variant
Dim outputRow As Long, pairCount As Integer
Dim totalHours As Double, status As String
Dim dateDict As Object
Dim cellValue As String, cleanTime As String
Dim recordType As String
Dim key As Variant
Dim keysArray() As Variant

' 设置原始数据表和输出表
Set srcSheet = ThisWorkbook.Sheets(1)
Set destSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
destSheet.Name = "考勤报表"

' 创建输出表头
CreateOutputHeader destSheet

' 获取原始数据最后一行
lastRow = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row

' 使用字典按员工ID和日期分组数据
Set dateDict = CreateObject("Scripting.Dictionary")

' 处理原始数据（从第2行开始）
For i = 2 To lastRow
' 清理日期时间列（第11列）
cellValue = srcSheet.Cells(i, 11).Value
' 去除多余空格
cleanTime = Application.WorksheetFunction.Trim(Replace(cellValue, " ", " "))

' 解析日期和时间
If IsDate(cleanTime) Then
fullDateTime = CDate(cleanTime)
empID = srcSheet.Cells(i, 2).Value
currentDate = DateValue(fullDateTime)
recordType = srcSheet.Cells(i, 8).Value
recordTime = TimeValue(fullDateTime)

' 获取员工姓名
empName = srcSheet.Cells(i, 1).Value

' 创建复合键：员工ID & 日期
key = empID & "|" & Format(currentDate, "yyyy-mm-dd")

If Not dateDict.Exists(key) Then
' 存储员工姓名、日期和记录集合
dateDict.Add key, Array(empName, currentDate, New Collection)
End If

' 添加记录到集合
dateDict(key)(2).Add Array(recordType, recordTime, i)
Else
' 记录无法解析的时间
Debug.Print "无法解析日期: " & cellValue & " 在第" & i & "行"
End If
Next i

' 处理每个员工每天的记录
outputRow = 2
keysArray = dateDict.Keys

For i = 0 To UBound(keysArray)
key = keysArray(i)

' 提取员工信息
Dim empInfo As Variant
empInfo = dateDict(key)
empName = empInfo(0)
currentDate = empInfo(1)
empID = Split(key, "|")(0)

' 修复：将集合提取到变量中
Dim dailyRecords As Collection
Set dailyRecords = empInfo(2)

' 对记录集合进行排序
SortCollection dailyRecords

' 匹配出入对
Set timePairs = MatchTimePairs(dailyRecords, currentDate, status)

' 准备输出数据
destSheet.Cells(outputRow, 1).Value = empName
destSheet.Cells(outputRow, 2).Value = empID
destSheet.Cells(outputRow, 3).Value = currentDate

' 输出最多10组时间对
pairCount = 1
totalHours = 0
For Each pair In timePairs
If pairCount > 10 Then Exit For

' 输出上班时间
If Not IsEmpty(pair(0)) Then
destSheet.Cells(outputRow, 3 + pairCount * 2 - 1).Value = Format(pair(0), "hh:mm:ss")
End If

' 输出下班时间
If Not IsEmpty(pair(1)) Then
destSheet.Cells(outputRow, 3 + pairCount * 2).Value = Format(pair(1), "hh:mm:ss")
End If

' 计算有效工作时长
If Not IsEmpty(pair(0)) And Not IsEmpty(pair(1)) Then
totalHours = totalHours + (pair(1) - pair(0)) * 24
End If

pairCount = pairCount + 1
Next pair

' 输出总时长和状态
destSheet.Cells(outputRow, 24).Value = Round(totalHours, 2)
destSheet.Cells(outputRow, 25).Value = status

' 标记异常状态为红色
If status = "异常" Then
destSheet.Cells(outputRow, 25).Font.Color = RGB(255, 0, 0)
Else
destSheet.Cells(outputRow, 25).Font.Color = RGB(0, 0, 0)
End If

outputRow = outputRow + 1
Next i

' 自动调整列宽
destSheet.Columns.AutoFit
MsgBox "处理完成！共生成 " & (outputRow - 2) & " 条考勤记录", vbInformation
End Sub

' 创建输出表头
Sub CreateOutputHeader(ws As Worksheet)
Dim i As Integer
ws.Cells(1, 1).Value = "姓名"
ws.Cells(1, 2).Value = "员工ID"
ws.Cells(1, 3).Value = "日期"

For i = 1 To 10
ws.Cells(1, 3 + i * 2 - 1).Value = "上班时间" & i
ws.Cells(1, 3 + i * 2).Value = "下班时间" & i
Next i

ws.Cells(1, 24).Value = "工作时长"
ws.Cells(1, 25).Value = "状态"
End Sub

' 匹配时间对函数
Function MatchTimePairs(records As Collection, currentDate As Date, ByRef status As String) As Collection
Dim inStack As New Collection
Dim timePairs As New Collection
Dim i As Long, record As Variant
Dim inTime As Date, outTime As Date

status = "正常"

' 处理所有记录
For i = 1 To records.Count
record = records(i) ' record是数组: (0)=类型, (1)=时间, (2)=行号

If record(0) = "入" Then
' 处理入记录 - 推入栈
inStack.Add Array(record(1), i) ' 存储时间和行号
ElseIf record(0) = "出" Then
' 处理出记录
If inStack.Count > 0 Then
' 正常匹配：入->出
Dim lastIn As Variant
lastIn = inStack(inStack.Count) ' 获取最近的入记录
inTime = lastIn(0) ' 时间部分
inStack.Remove inStack.Count ' 从栈中移除

outTime = record(1) ' 出时间
timePairs.Add Array(inTime, outTime)
Else
' 没有匹配的入记录 - 规则3
If timePairs.Count = 0 Then
' 当天第一条记录是"出"
If record(1) < TimeSerial(9, 0, 0) Then
' 夜班处理 - 规则3
timePairs.Add Array(TimeSerial(0, 0, 0), record(1))
status = "夜班"
Else
' 异常情况 - 规则2
timePairs.Add Array(Empty, record(1))
status = "异常"
End If
Else
' 多余的出记录，视为异常
timePairs.Add Array(Empty, record(1))
status = "异常"
End If
End If
End If
Next i

' 处理剩余的入记录 - 规则4
While inStack.Count > 0
Dim inRecord As Variant
inRecord = inStack(inStack.Count)
inTime = inRecord(0)
inStack.Remove inStack.Count

If inTime >= TimeSerial(16, 0, 0) Then
' 夜班处理 - 规则4
timePairs.Add Array(inTime, TimeSerial(23, 59, 59))
If status = "正常" Then status = "夜班"
Else
' 未匹配的出记录，视为异常
timePairs.Add Array(inTime, Empty)
status = "异常"
End If
Wend

Set MatchTimePairs = timePairs
End Function

' 按时间排序集合
Sub SortCollection(coll As Collection)
Dim arr() As Variant
Dim i As Long, j As Long
Dim temp As Variant

' 将集合转换为数组
ReDim arr(1 To coll.Count)
For i = 1 To coll.Count
arr(i) = coll(i)
Next i

' 使用冒泡排序按时间升序
For i = 1 To UBound(arr) - 1
For j = i + 1 To UBound(arr)
' 比较时间部分 (arr(i)(1) 是时间值)
If arr(i)(1) > arr(j)(1) Then
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i

' 清空原始集合
Do While coll.Count > 0
coll.Remove 1
Loop

' 将排序后的数组重新加入集合
For i = 1 To UBound(arr)
coll.Add arr(i)
Next i
End Sub

学习资料见知识星球。

以上就是今天要分享的技巧，你学会了吗？若有什么问题，欢迎在下方留言。

快来试试吧，小琥 my21ke007。获取 1000个免费 Excel模板福利​​​​！

更多技巧， www.excelbook.cn

欢迎 加入 零售创新 知识星球，知识星球主要以数据分析、报告分享、数据工具讨论为主；