VBA快速动态考勤统计

news2024/11/27 14:32:22

实例需求：某公司的上下班打卡记录如下所示，其中Table_In为上班打卡记录，Table_Out为下班打卡记录。
在这里插入图片描述
现在需要根据日期整理为如下格式的考勤表。需要注意如下几点：

每天的打卡次数不确定
最后一列Total/Day统计该天的出勤总时长，忽略有缺卡的时间段
对于缺卡记录标记为Missing，例如10/14，员工108500，7:59:34和14:59:34两次上班打卡记录之间并没有下班打卡记录，那么7:59:34对应的下班打卡记录为缺失

示例代码如下。

Sub Demo()
    Const MISSING_DT = "Missing"
    Dim objDic As Object, rngData As Range
    Dim i As Long, j As Long
    Dim arrData, arrRes(), arrTotal(), sKey
    Dim oSht As Worksheet, srcSheet As Worksheet
    Set objDic = CreateObject("scripting.dictionary")
    Set srcSheet = Sheets("Sheet1") 
    Set oSht = Sheets.Add
    srcSheet.ListObjects("Table_In").Range.Copy oSht.Cells(1, 1)
    oSht.Range("D1") = "Flag"
    oSht.Range(oSht.ListObjects(1).Name & "[Flag]").Value = "In"
    srcSheet.ListObjects("Table_Out").DataBodyRange.Copy oSht.Cells(1, 1).End(xlDown).Offset(1)
    oSht.Range(oSht.ListObjects(1).Name & "[Flag]").SpecialCells(xlCellTypeBlanks).Value = "Out"
    oSht.ListObjects(1).Range.Sort key1:="ID Number", Order1:=xlAscending, key2:="Date", _
        Order2:=xlAscending, key3:="Time", Order3:=xlAscending, Header:=xlYes
    arrData = oSht.ListObjects(1).DataBodyRange.Value
    oSht.ListObjects(1).Range.Clear
    Dim pair_cnt As Integer
    ReDim arrRes(UBound(arrData), 1 To 2)
    ReDim arrTotal(UBound(arrData), 0)
    arrRes(0, 1) = "Date"
    arrRes(0, 2) = "ID Number"
    arrTotal(0, 0) = "Total/Day"
    j = 0: pair_cnt = 0
    For i = LBound(arrData) To UBound(arrData)
        sKey = arrData(i, 1) & "|" & arrData(i, 2)
        If objDic.exists(sKey) Then
            objDic(sKey) = objDic(sKey) + 1
        Else
            j = j + 1
            arrRes(j, 1) = arrData(i, 1)
            arrRes(j, 2) = arrData(i, 2)
            objDic(sKey) = 1
        End If
        If objDic(sKey) > pair_cnt Then
            pair_cnt = objDic(sKey)
            ReDim Preserve arrRes(UBound(arrData), 1 To pair_cnt * 2 + 2)
            arrRes(0, pair_cnt * 2 + 1) = "In_" & pair_cnt
            arrRes(0, pair_cnt * 2 + 2) = "Out_" & pair_cnt
        End If
        If arrData(i, 4) = "In" Then
            arrRes(j, objDic(sKey) * 2 + 1) = arrData(i, 3)
            If arrData(i + 1, 4) = "Out" Then
                arrRes(j, objDic(sKey) * 2 + 2) = arrData(i + 1, 3)
                arrTotal(j, 0) = arrTotal(j, 0) + arrData(i + 1, 3) - arrData(i, 3)
                i = i + 1
            Else
                arrRes(j, objDic(sKey) * 2 + 2) = MISSING_DT
            End If
        Else
            arrRes(j, objDic(sKey) * 2 + 1) = MISSING_DT
            arrRes(j, objDic(sKey) * 2 + 2) = arrData(i, 3)
        End If
    Next i
    With oSht.Range("A3")
        .Resize(UBound(arrRes), UBound(arrRes, 2)).Value = arrRes
        .Offset(0, 2).Resize(, pair_cnt * 2 + 1).EntireColumn.NumberFormat = "h:mm:ss"
        .End(xlToRight).Offset(0, 1).Resize(UBound(arrRes), 1) = arrTotal
    End With
End Sub

【代码解析】
第7行代码创建自怼对象
第9行代码添加工作表用于保存临时数据。
第10行代码将表格Table_In的数据拷贝到新建工作表。
第11~12行代码增加新列Flag，并填充In，标记为上班打卡记录。
第13~14行代码表格Table_Out的数据拷贝到新建工作表，并增加新列。
第15行代码在新建工作表中对数据进行排序，排序字段依次为：ID Number, Date, Time
第16行代码将排序后的数据读取到数组中。
第18行代码清除新建工作表中的数据，以便于后续用于保存统计结果。
第20行代码声明数组arrRes用于保存考勤表。
第21行代码声明数组arrTotal用于保存出勤时间。
第22~24行代码填充表头
第26~55行代码循环处理考勤数据。
第27行代码将ID Number, Date作为排重统计的关键字段。
第28行代码判断字段中是否已经存在指定的关键字段。
如果已经存在，第29行代码将统计出现次数。
如果不存在，第32~33行代码将ID Number, Date保存到结果数组中。
第36~41行代码根据统计结果扩展结果数组。
第42~54行代码统计出勤时间和缺卡记录。
如果当前行为上班打卡记录，第43行代码记录上班打卡时间。
如果下一行为下班打卡记录，第45行代码记录下班打卡时间，并且第46行代码统计出勤时间。
如果下一行为不是下班打卡记录，第49行代码记录缺卡。
类似逻辑，第52~53行代码记录上班缺卡和相应的下班打卡时间。
第57行代码将考勤结果写入结果工作表中。
第58行代码设置最后一列的数字格式。
第59行代码将出勤时间写入工作表。