没有过时呀。有个小伙伴一直问我考勤系统脚本的代码。我在这里分享出来。
写这个脚本的背景是CTO和HR商量了下，整个信息中心和业务部门分开做考勤规则。
我们的考勤系统只是记录打卡，但不会判断迟到、漏打卡、加班等等的规则。
之前也是一个程序员帮HR写的程序，此次复杂度加倍。CTO问各位研发总监有木有人要开发下。
无人回应。
做数据的我，弱弱的举了小爪，说我可以帮忙写下。
花了半天就写好了，还设想了各种遇到的情况。HR惊叹于我的速度，说上个程序员花了两周...我汗颜。
HR们，如果还在为考勤烦恼，以下可以下载下来
百度网盘：链接：http://pan.baidu.com/s/1pLuRwoj 密码：w47g
以下截图，我的代码都详细写好了注释。大家可以按照注释修改
![]()
![]()
![]()
代码如下：
Sub Organize_Attendance()
On Error Resume Next
Application.ScreenUpdating = False
Dim Cus_FirstDay As Date, Cus_Lastday As Date, abcd As Date, Cus_Days, St2_Row, Arr_Pointer, Arr_Pointer2
Dim Sht, St1, St2, St3
Dim Arr(0 To 31000, 1 To 14), Date1, Date2, Date3, Record, Date4, Name
'整理表页名称，用于判断是否缺失
txt = ""
a = 0
b = 0
c = 0
For Each Sht In Sheets
If Sht.Name = "控制表格" Then a = 1
If Sht.Name = "出勤记录" Then b = 1
If Sht.Name = "输出表格" Then c = 1
Next
'查找是否有“控制表格”和“出勤记录”两张表
If a 1 And b = 1 Then
txt = "没有找到控制表格表页"
ElseIf a = 1 And b 1 Then
txt = "没有找到出勤记录表页"
ElseIf a 1 And b 1 Then
txt = "没有找到控制表格、出勤记录表页"
End If
If txt "" Then
MsgBox (txt)
Exit Sub
End If
'如果有输出表格，则进行清空，如果没有新建一个
If c = 1 Then
Sheets("输出表格").Cells.Delete
Else
Sheets.Add
ActiveSheet.Name = "输出表格"
End If
Set St1 = Sheets("控制表格")
Set St2 = Sheets("出勤记录")
Set St3 = Sheets("输出表格")
'定义表头内容
Arr(0, 1) = "工号"
Arr(0, 2) = "姓名"
Arr(0, 3) = "单位名称"
Arr(0, 4) = "考勤日期"
Arr(0, 5) = "班次"
Arr(0, 6) = "上班"
Arr(0, 7) = "下班"
Arr(0, 8) = "是否跨天"
Arr(0, 9) = "在司时间"
Arr(0, 10) = "是否足够9小时"
Arr(0, 11) = "考勤是否合理"
Arr(0, 12) = "是否缺勤"
Arr(0, 13) = "备注"
'定义节假日、倒休等特殊日期字典
Set Date1 = CreateObject("Scripting.Dictionary")
Set Date2 = CreateObject("Scripting.Dictionary")
Set Date3 = CreateObject("Scripting.Dictionary")
For Each Rng In St1.Range("H2:H" & St1.Range("H65536").End(xlUp).Row)
Date1.Add Rng.Value, Rng.Value
Next
For Each Rng In St1.Range("I2:I" & St1.Range("I65536").End(xlUp).Row)
Date2.Add Rng.Value, Rng.Value
Next
For Each Rng In St1.Range("J2:J" & St1.Range("J65536").End(xlUp).Row)
Date3.Add Rng.Value, Rng.Value
Next
'记录出勤记录行数
St2_Row = St2.Range("A65536").End(xlUp).Row
'定义月份第一天，当月天数
'Cus_FirstDay = DateSerial(St1.[b2].Value, St1.[b3].Value, 1)
'Cus_Lastday = DateSerial(St1.[b2].Value, St1.[b3].Value + 1, 0)
For i = 2 To St2_Row
abcd = St2.Cells(i, 4).Value
If Cus_FirstDay = #12:00:00 AM# Or Cus_FirstDay > abcd Then
Cus_FirstDay = abcd
End If
If Cus_Lastday = #12:00:00 AM# Or Cus_Lastday < abcd Then
Cus_Lastday = abcd
End If
Next
Cus_Days = DateDiff("d", Cus_FirstDay, Cus_Lastday) + 1
'定义当月班次数组
ReDim Date4(1 To Cus_Days, 1 To 2)
For i = 1 To Cus_Days
a = DateAdd("d", i - 1, Cus_FirstDay)
Date4(i, 1) = a
If Date1.Exists(a) Then
Date4(i, 2) = "三倍节假日"
ElseIf Date2.Exists(a) Then
Date4(i, 2) = "周末"
ElseIf Date3.Exists(a) Then
Date4(i, 2) = "工作日"
ElseIf WorksheetFunction.Weekday(a, 2) = 6 Then
Date4(i, 2) = "周六"
ElseIf WorksheetFunction.Weekday(a, 2) = 7 Then
Date4(i, 2) = "周日"
Else
Date4(i, 2) = "工作日"
End If
Next
'定义员工工号字典
Set Name = CreateObject("Scripting.Dictionary")
'定义当前员工第一行指针
Arr_Pointer = -Cus_Days
'开始按照出勤记录每行循环处理数据，记录工号、姓名、公司、班次、日期、上下班时间、是否跨天的数据
For i = 2 To St2_Row
'将出勤记录当前行转换为数组
Record = WorksheetFunction.Transpose(WorksheetFunction.Transpose(St2.Range("A" & i & ":E" & i).Value))
'检测是否是录入过该员工
If Not Name.Exists(Record(1)) Then
'如果是第一次录入，增加工号字典，更改第一行指针，在数组内添加该员工一整月天数的前5列数据
Name.Add Record(1), Record(1)
Arr_Pointer = Arr_Pointer + Cus_Days
For n = 1 To Cus_Days
Arr(Arr_Pointer + n, 1) = Record(1)
Arr(Arr_Pointer + n, 2) = Record(2)
Arr(Arr_Pointer + n, 3) = Record(3)
Arr(Arr_Pointer + n, 4) = Date4(n, 1)
Arr(Arr_Pointer + n, 5) = Date4(n, 2)
Next
End If
'判断时间属性，填入数组
Arr_Pointer2 = Arr_Pointer + Day(St2.Cells(i, 4).Value)
If St2.Cells(i, 5).Value >= TimeValue("13:00:00") Then '如果打卡时间超过13点
If Arr(Arr_Pointer2, 7) = "" Then
Arr(Arr_Pointer2, 7) = St2.Cells(i, 5).Value '如果数组里还没有记录，则将单元格写入数组
ElseIf Arr(Arr_Pointer2, 7) < St2.Cells(i, 5).Value Then
Arr(Arr_Pointer2, 7) = St2.Cells(i, 5).Value '如果数组的记录小于单元格，则将单元格写入数组（下班打卡取较大数据）
End If
ElseIf St2.Cells(i, 5).Value < TimeValue("6:00:00") Then '如果打卡时间早于6点
If Day(Record(4)) = 1 Then
Arr(Arr_Pointer2, 13) = "上个月末最后一天有加班"
Else
Arr_Pointer2 = Arr_Pointer2 - 1 '指针时间提前一天
If Arr(Arr_Pointer2, 7) = "" Then
Arr(Arr_Pointer2, 7) = St2.Cells(i, 5).Value '如果数组里还没有记录，则将单元格写入数组
ElseIf Arr(Arr_Pointer2, 7) >= TimeValue("13:00:00") Then
Arr(Arr_Pointer2, 7) = St2.Cells(i, 5).Value '如果数组里的记录是前一天晚上的记录，则将单元格写入数组（凌晨打卡要晚于前一天晚上）
ElseIf St2.Cells(i, 5).Value > Arr(Arr_Pointer2, 7) Then
Arr(Arr_Pointer2, 7) = St2.Cells(i, 5).Value '如果数组里的记录是凌晨的，并且小于单元格，则将单元格写入数组（下班打卡取较大数据）
End If
Arr(Arr_Pointer2, 8) = "是"
End If
Else '如果打卡时间介于6点到13点
If Arr(Arr_Pointer2, 6) = "" Then
Arr(Arr_Pointer2, 6) = St2.Cells(i, 5).Value '如果数组里还没有记录，则将单元格写入数组
ElseIf Arr(Arr_Pointer2, 6) > St2.Cells(i, 5).Value Then
Arr(Arr_Pointer2, 6) = St2.Cells(i, 5).Value '如果数组的记录大于单元格，则将单元格写入数组（上班打卡取较小数据）
End If
End If
Next
For i = 1 To Arr_Pointer + Cus_Days
'备注周末or节假日
' If Arr(i, 5) = "周末" Or Arr(i, 5) = "三倍节假日" Then
' If Arr(i, 6) = "" And Arr(i, 7) = "" Then Arr(i, 13) = Arr(i, 13) & " 周末or节假日 "
' End If
'如果上下班都有时间，则填充在司时间
If Arr(i, 6) "" And Arr(i, 7) "" Then
If Arr(i, 8) = "是" Then
Arr(i, 9) = Arr(i, 7) + 1 - Arr(i, 6)
Else
Arr(i, 9) = Arr(i, 7) - Arr(i, 6)
End If
Arr(i, 9) = Application.WorksheetFunction.RoundDown(Arr(i, 9) * 24, 2)
If Arr(i, 9) >= 9 Then Arr(i, 10) = "是"
End If
'判断是否缺上下班打卡记录
If Arr(i, 5) = "工作日" Then
'判断总部考勤是否合理
If Arr(i, 3) = "总部" Then
If Arr(i, 6) = "" And Arr(i, 7) = "" Then
Arr(i, 12) = "缺勤"
ElseIf Arr(i, 6) = "" Or Arr(i, 7) = "" Then
Arr(i, 12) = "漏打卡"
ElseIf Arr(i, 6) = TimeValue("17:30:00") Or Arr(i, 7) = TimeValue("22:00:00") And _
Arr(i, 6) = TimeValue("18:00:00") Then
Arr(i, 11) = "合理"
Else
Arr(i, 11) = "迟到or早退"
End If
End If
End If
Next
'设置输出表的格式
St3.Columns("A:A").NumberFormatLocal = "@"
St3.Columns("D:D").NumberFormatLocal = "[$-F800]dddd, mmmm dd, yyyy"
St3.Columns("F:G").NumberFormatLocal = "[$-F400]h:mm:ss AM/PM"
St3.Columns("I:I").Style = "Comma"
St3.Columns("B:M").ColumnWidth = 12
'结果数组输出到表格内
St3.Range("A1:N" & Arr_Pointer + Cus_Days) = Arr()
'清除无打卡记录的休息日行
'St3.Columns("N:N").SpecialCells(xlCellTypeConstants, 23).EntireRow.Delete
Application.ScreenUpdating = True
St3.Select
St3.Range("a2").Select
ActiveWindow.FreezePanes = True
End Sub
|
转播
