VBA 根据飞书导出的考勤记录生成对应的考勤记录汇总表
Sub 一键生成考勤数据()
Dim pathA As String
Dim pathB As String
Dim pathC As String
Dim pathD As String
Dim path As String
Dim newPath As String
Dim newFileName As String
Dim fso As Object
' 创建FileSystemObject实例
Set fso = CreateObject("Scripting.FileSystemObject")
pathA = ThisWorkbook.path & "\考勤汇总表模板\考勤汇总表模板.xlsx"
pathB = ThisWorkbook.path & "\考勤数据\"
pathB = ThisWorkbook.path & "\考勤数据\" & Dir(pathB) '月度汇总表
pathC = ThisWorkbook.path & "\上月考勤汇总表\"
pathC = ThisWorkbook.path & "\上月考勤汇总表\" & Dir(pathC) '上月考勤表汇总数据
newPath = ThisWorkbook.path & "\生成当月的考勤数据\"
newFileName = ThisWorkbook.Worksheets(1).Range("A2") & "考勤汇总表.xlsx"
path = newPath & newFileName
' 确保路径存在
If Not fso.FolderExists(newPath) Then
MsgBox "指定的路径不存在！", vbExclamation
Exit Sub
End If
' 复制文件
FileCopy pathA, path
Set fso = Nothing
Dim wbt As Workbook '程序工作表
Dim sht As Worksheet
Dim wbk As Workbook '考勤工作表
Dim shk As Worksheet
Dim wby As Workbook '月度汇总工作表
Dim shy As Worksheet
Set wbt = ThisWorkbook
Set sht = ThisWorkbook.Worksheets(1)
Set wbk = Workbooks.Open(path)
Set shk = wbk.Worksheets(1)
Dim yzcdsum As Double
Dim chdao As Double
For i = 4 To 2000
If Trim(shk.Cells(i, 2)) <> "" Then
shk.Cells(i, 1) = sht.Range("A2")
shk.Cells(i, 6) = sht.Range("B2")
ElseIf Trim(shk.Cells(i, 2)) = "" Then
Exit For
End If
Next i
i = 0
Set wby = Workbooks.Open(pathB)
Set shy = wby.Worksheets(1)
For i = 4 To 2000
If Trim(shk.Cells(i, 3)) <> "" Then
For j = 3 To 2000
If Trim(shk.Cells(i, 3)) = Trim(shy.Cells(j, 1)) Then '名字相等
Trim(shk.Cells(i, 9)) = Trim(shy.Cells(j, 26)) '事假
Trim(shk.Cells(i, 10)) = Trim(shy.Cells(j, 29)) '病假
If CDbl(Trim(shy.Cells(j, 19))) = 0 And CDbl(Trim(sht.Cells(i, 14))) > 0 And CDbl(Trim(shy.Cells(j, 17))) = 0 Then '没有迟到和严重迟到
Trim(shk.Cells(i, 10)) = Trim(shy.Cells(j, 17)) '迟到时长，严重迟到时长都为0
ElseIf CDbl(Trim(shy.Cells(j, 19))) = 0 And CDbl(Trim(sht.Cells(i, 14))) >= 0 And CDbl(Trim(shy.Cells(j, 17))) > 0 Then '有迟到没有严重迟到
chdao = 0 '计算迟到是否排除了免迟到
For m = 70 To 200
If Trim(shy.Cells(j, m)) <> "" Then
cda = "迟到"
strword = "严重迟到"
strzif = Trim(shy.Cells(j, m))
If (ContainsWord(strzif, strword) = False) And ContainsWord(strzif, cda) Then
reslut = Split(strzif, "分")
rel = Split(reslut(0), "到")
If CDbl(rel(1)) <= 6 And CDbl(Trim(sht.Cells(i, 14))) > 0 Then
sht.Cells(i, 14) = CDbl(Trim(sht.Cells(i, 14))) - 1
ElseIf CDbl(rel(1)) > 6 And CDbl(Trim(sht.Cells(i, 14))) > 0 Then
chdao = chdao + CDbl(rel(1))
ElseIf CDbl(rel(1)) > 0 And CDbl(Trim(sht.Cells(i, 14))) = 0 Then
chdao = chdao + CDbl(rel(1))
End
End If
ElseIf CDbl(Trim(shy.Cells(j, 19))) > 0 And CDbl(Trim(sht.Cells(i, 14))) = 0 And CDbl(Trim(shy.Cells(j, 17))) = 0 Then '有严重迟到，没有迟到
'判断异常数据
'统计严重迟到分钟数据
yzcdsum = 0 '分钟
For m = 70 To 200
If Trim(shy.Cells(j, m)) <> "" Then
strword = "严重迟到"
strzif = Trim(shy.Cells(j, m))
xqj = Trim(shy.Cells(2, m))
If ContainsWord(strzif, strword) And (ContainsWord(strzif, "外出") = False) And (ContainsWord(xqj, "星期一") = False) Then '严重迟到不是周五加班很晚的情况
reslut = Split(strzif, "分")
rel = Split(reslut(0), "到")
yzcdsum = yzcdsum + CDbl(rel(1))
ElseIf ContainsWord(strzif, strword) And (ContainsWord(strzif, "外出") = False) And (ContainsWord(xqj, "星期一") = True) Then '判定周五的下班时间是否是22点后
'如果是周五22点下班就不计入，如果不是就需要计入
End If
Else
Exit For
End If
Next m
'Trim(shk.Cells(i, 10)) = CDbl(Trim(shy.Cells(j, 17))) + (yzcdsum / 60) '兑换小时后和迟到小时相加
End If
End If
Next j
ElseIf Trim(shk.Cells(i, 3)) = "" Then
Exit For
End If
Next i
End Sub
Function ContainsWord(str As String, word As String) As Boolean
ContainsWord = InStr(1, str, word, vbTextCompare) > 0
End Function