Excel·VBA考勤打卡记录统计结果

之前写过的《Excel·VBA考勤打卡记录统计出勤小时》，是统计出勤小时；
之前写过的《Excel·VBA考勤打卡记录数据整理》，是整理上下班时间；
而《excelhome提问-考勤统计》，则是按照下列要求统计考勤结果：
1，上班时间晚于8点，算迟到
2，下班时间早于18点，算早退
3，上下班仅打卡1次，算休息半天
4，当天没有打卡记录，算未打卡
同时为避免一个班次多次打卡/每天打卡次数超过2次造成错误，改为获取当日打卡时间的max、min值判断获取考勤结果

与之前的文章同样采用字典嵌套字典的方式，同样由于office不支持时间数组max、min操作，故时间先读取为字符串，再转为double类型；同时对日期进行排序方便查看，排序调用了bubble_sort函数，代码详见《Excel·VBA数组冒泡排序函数》

Sub 考勤统计()
    Dim arr, brr, crr, name_dict As Object, date_dict As Object, i&, j&, r&, c&, result
    arr = [a1].CurrentRegion.Value: tm = Timer
    Set name_dict = CreateObject("scripting.dictionary")
    Set date_dict = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        xm = arr(i, 2): rq = DateValue(arr(i, 4)): date_dict(rq) = ""
        sj = Format(TimeValue(arr(i, 4)), "0.0000000000")
        'Debug.Print xm, TypeName(xm), rq, TypeName(rq), sj, TypeName(sj)
        If Not name_dict.exists(xm) Then  '姓名字典键不存在，新增
            Set name_dict(xm) = CreateObject("scripting.dictionary")  '字典嵌套
        End If
        name_dict(xm)(rq) = name_dict(xm)(rq) & "," & sj
    Next
    ReDim result(name_dict.Count, date_dict.Count)  '从0开始计数，0即为条件，1开始为数据
    trr = bubble_sort(date_dict.keys)  '日期排序
    For j = 1 To UBound(result, 2)  '日期赋值
        result(0, j) = trr(j - 1)
    Next
    For Each n In name_dict.keys
        r = r + 1: result(r, 0) = n
        For c = 1 To UBound(result, 2)
            If Not name_dict(n).exists(result(0, c)) Then
                result(r, c) = "未打卡"
            Else
                '字符串以,开头，所以brr(0)为空值
                brr = Split(name_dict(n)(result(0, c)), ","): ReDim crr(1 To UBound(brr))
                For i = 1 To UBound(brr)  '时间string数组转double数组
                    crr(i) = CDbl(brr(i))
                Next
                max_t = WorksheetFunction.Max(crr): min_t = WorksheetFunction.Min(crr)
                '上班下班只要缺1个卡即为"休息半天"
                If max_t < #10:00:00 AM# Or min_t > #2:00:00 PM# Then
                    result(r, c) = result(r, c) & vbLf & "休息半天"
                End If
                If min_t > #8:00:00 AM# And min_t < #10:00:00 AM# Then
                    result(r, c) = result(r, c) & vbLf & "迟到"
                End If
                If max_t > #2:00:00 PM# And max_t < #6:00:00 PM# Then
                    result(r, c) = result(r, c) & vbLf & "早退"
                End If
            End If
        Next
    Next
    For i = 1 To UBound(result)  '清除开头的换行符
        For j = 1 To UBound(result, 2)
            If Len(result(i, j)) > 0 Then
                If Left(result(i, j), 1) = vbLf Then
                    result(i, j) = Mid(result(i, j), 2)
                End If
            End If
        Next
    Next
    With Worksheets("考勤统计表")  '结果赋值
        .Cells.Clear
        .Cells(1, 1).Resize(UBound(result) + 1, UBound(result, 2) + 1) = result
        .Cells(1, 1) = "姓名/日期"
        With .[a1].CurrentRegion
            .Borders.LineStyle = xlContinuous
            .Font.Name = "微软雅黑"
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With
    Debug.Print "考勤统计完成，用时：" & Format(Timer - tm, "0.00")
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

结果

附件
CSDN：《Excel·VBA考勤打卡记录统计结果（附件）》
百度网盘：《Excel·VBA考勤打卡记录统计结果（附件）》，提取码：3jp3