1 '自动考勤计算
2 'by Captain Amazing
3 '2020/7/6
4 '2022/7/4更新迟到写入功能
5 '2023/7/3做大的更改
6 Sub AutomaticAttendanceCounting()
7
8 Dim s, partStr As String '声明打卡记录串
9
10 Dim bottom As Integer '表示最大使用的行数
11
12 Dim Mins, totalMins As Integer '表示每次迟到分钟数和总计迟到分钟数
13
14 m = Month(Now) '取得当前月份, 年份
15 yy = Year(Now)
16 daysOfLastMonth = Day(DateSerial(yy, m, 1 - 1)) '获取当前月1号的前一天的日期数, 就是上月的天数
17
18 bottom = ActiveSheet.UsedRange.Rows.Count '设置最大行号
19
20 For y = bottom To 1 Step -1
21 If Range("B" & y) = "1" Then
22 Rows(y + 1).Resize(2).Insert '循环处理每一行, 遇到1号日期就插入两个空行用于统计
23
24 For x = 2 To (daysOfLastMonth + 1) Step 1 '循环处理每一天
25
26 For n = y + 3 To bottom + 2
27 s = s + Trim(Cells(n, x)) '将一天中所有的打卡记录合并在一起
28 Next
29
30 If Len(s) = 0 Then
31 Cells(y + 1, x) = "请假" '没有打卡记录算请假
32
33 ElseIf Len(s) <= 6 Then
34 Cells(y + 1, x) = "异常" '一天只打一次卡标记为异常
35
36 Else '打两次以上卡根据时间来设置迟到或加班或早退
37
38 partStr = Left(s, 5) '处理第一次打卡(上班)
39 Mins = DateDiff("n", TimeValue("7:30"), TimeValue(partStr))
40
41 If Mins > 0 And Mins < 60 Then
42 Cells(y + 1, x) = "迟到" & Mins
43 totalMins = totalMins + Mins
44 ElseIf Mins >= 60 Then
45 Cells(y + 1, x) = "上请"
46 End If
47 '处理最后一次打卡(下班)
48 partStr = Right(s, 6)
49 Mins = DateDiff("n", TimeValue("18:00"), TimeValue(partStr))
50
51 If Mins >= 25 Then
52 Cells(y + 2, x) = "加班" & Round(Mins / 60, 1)
53 ElseIf Mins >= -60 And Mins < -30 Then
54 Cells(y + 2, x) = "早退"
55 ElseIf Mins < -60 Then
56 Cells(y + 2, x) = "下请"
57 End If
58 End If
59
60 s = "" '处理完一天的上下班考勤数据后重置打卡变量s, 迟到分钟数
61 Mins = 0
62 Next
63
64 bottom = y - 2 '处理完成某一员工, 向上移动2行, 即1号上面的2行, 写入迟到分钟数, 重置迟到总分钟数
65 Cells(y + 1, x + 1) = "迟到" & totalMins
66 totalMins = 0
67 End If
68 Next
69 End Sub
