|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
你的附件中 增加3个表，如下图
再将以下代码复制到模块1中
Sub 考勤整合()
' https://club.excelhome.net/forum ... amp;_dsign=67dc65cf
' 2024-5-24
Sheet2.Select
Cells.NumberFormatLocal = "@"
Cells.ClearContents ' 清空上一次的统计数据
Cells.Interior.ColorIndex = xlNone
Cells(1, 1).Value = "工号"
Cells(1, 2).Value = "姓名"
Cells(1, 3).Value = "部门"
Cells(1, 4).Value = "班别"
For i = 1 To 31
Cells(1, i + 4).Value = i ' 写上日期
Next i
x2 = 1
jsh = Sheet1.UsedRange.Rows.Count ' 依据数据范围，获得行数，尾部数据隐藏不影响计数
For x1 = 5 To jsh
If Sheet1.Cells(x1, 11).Value = "姓名：" Then ' 找到姓名，则
x2 = x2 + 1
Sheet2.Cells(x2, 1).Value = Sheet1.Cells(x1, 6).Value ' 记录工号
Sheet2.Cells(x2, 2).Value = Sheet1.Cells(x1, 12).Value ' 记录姓名
Sheet2.Cells(x2, 3).Value = Sheet1.Cells(x1, 24).Value ' 记录部门
Sheet2.Cells(x2, 4).Value = "正班"
Sheet2.Cells(x2 + 1, 4).Value = "加班"
Sheet2.Cells(x2 + 1, 1).Value = Sheet1.Cells(x1, 6).Value ' 记录工号
Sheet2.Cells(x2 + 1, 2).Value = Sheet1.Cells(x1, 12).Value ' 记录姓名
Sheet2.Cells(x2 + 1, 3).Value = Sheet1.Cells(x1, 24).Value ' 记录部门
x2 = x2 + 1
For k = x1 + 1 To jsh + 1 ' 从找到的姓名的下一行开始循环
If Sheet1.Cells(k, 11).Value = "姓名：" Then ' 如果找到下一个姓名，则确定行位置
i = k ' 定位到下一个姓名的前一行
Exit For ' 找到后退出循环
Else
i = k ' 没找到，则为最末的一位员工了
End If
Next k
jg = i - x1 - 1
Select Case jg
Case Is = 2
For y = 1 To 31 ' 按日期循环
Sheet2.Cells(x2 - 1, y + 4).Value = Sheet1.Cells(x1 + 2, y + 1).Value ' 记录一天的考勤
Next y
Case Is = 3
For y = 1 To 31
cqsj = "" ' 每天出勤赋初值
For x = x1 + 2 To i - 1
If IsEmpty(Sheet1.Cells(x, y + 1).Value) Then
Else
cqsj = cqsj & Chr(10) & Sheet1.Cells(x, y + 1).Value ' 把一天的考勤汇总在一起
End If
Next x
Sheet2.Cells(x2 - 1, y + 4).Value = Mid(cqsj, 2) ' 记录一天的考勤
'Sheet2.Cells(x2, y + 3).Select
Next y
Case Is = 4
For y = 1 To 31
cqsj = "" ' 每天出勤赋初值
For x = x1 + 2 To i - 2
If IsEmpty(Sheet1.Cells(x, y + 1).Value) Then
Else
cqsj = cqsj & Chr(10) & Sheet1.Cells(x, y + 1).Value ' 把一天的考勤汇总在一起
End If
Next x
Sheet2.Cells(x2 - 1, y + 4).Value = Mid(cqsj, 2) ' 记录一天的考勤
Sheet2.Cells(x2, y + 4).Value = Sheet1.Cells(x1 + 4, y + 1).Value ' 记录一天的考勤
Next y
End Select
End If
Next x1
Range("A1").Select
MsgBox "打卡机上的数据转换完成！"
End Sub
Sub 考勤取最值()
' https://club.excelhome.net/forum ... amp;_dsign=67dc65cf
' 2024-5-24
Sheet3.Select
Cells.NumberFormatLocal = "@"
Cells.ClearContents ' 清空上一次的统计数据
Sheet2.Select
Cells.Copy
Sheet3.Select
Range("A1").Select
ActiveSheet.Paste
x3 = 2
Do While Not (IsEmpty(Sheet3.Cells(x3, 2).Value))
For y = 1 To 31
If InStr(1, Sheet3.Cells(x3, y + 4).Value, ":", 1) <> 0 Then ' 如果有时间数
If mymax(Sheet3.Cells(x3, y + 4).Value, "A") = mymax(Sheet3.Cells(x3, y + 4).Value, "Z") Then ' 如果最大＝最小，说明只打卡1次
'Sheet3.Cells(x3, y + 4).Value = mymax(Sheet3.Cells(x3, y + 4).Value, "A")
Else
Sheet3.Cells(x3, y + 4).Value = mymax(Sheet3.Cells(x3, y + 4).Value, "A") & Chr(10) & mymax(Sheet3.Cells(x3, y + 4).Value, "Z")
End If
End If
Next y
x3 = x3 + 1
Loop
Range("A1").Select
End Sub
Function mymax(c_sj As String, Optional Options As String = "A") ' 接收数值的变量是 n 。Integer 类型的值只有5位数。 Variant 类型的数值范围最大
' 这是第一次用自定义函数，2022-10-14星期五
' 于2022-10-24星期一，将最大值和最小值二个自定义数合二为一，关键是括号中，增加“, Optional Options As String = "A" ”，变成一个接收数据，一个接收类型标记
' 这个自定义函数是算出最大值（一天打卡时间中的最大）
Dim arr(10)
Dim maxsj As String
maxsj = "00:00"
minsj = "99:99"
js = 0
ks = 1
For i = 1 To Len(c_sj)
If Mid(c_sj, i, 1) = Chr(10) Then
js = js + 1 ' 这个计数是为记录，换行符第几次出现
arr(js) = Mid(c_sj, ks, i - ks) ' arr(js)里，记录了 js 个时间值
ks = i + 1
End If
Next i
arr(js + 1) = Mid(c_sj, ks) ' 通过对接收到的数据，进行分享，暂存数组中
For j = 1 To js + 1
If arr(j) > maxsj Then 'And InStr(1, arr(j), ":", 1) <> 0 Then
maxsj = arr(j) ' 从数组中取出最大值
End If
If arr(j) < minsj And arr(j) <> " " And arr(j) <> "" Then
minsj = arr(j) ' 从数组中取出最小值
End If
Next j
If UCase(Options) = "A" Then
mymax = minsj ' 将处理的结果，反馈给 SUB ，再按SUB的规则处理（即赋值给单元格A1）
Else
mymax = maxsj
End If
End Function ' Function ....... End Function 是自定义函数的格式规范
Sub 计算每天的小时数()
'
' 遇到指定的符号（chr(10)）时，取值
'
' 时间：2024-5-24
'
' 思路：取出一天中的最大值与最小值，二值之差即为时间，超过8小时45分的部分为加班
'
Sheet4.Select
Cells.NumberFormatLocal = "@"
Cells.ClearContents ' 清空上一次的统计数据
Sheet3.Select
Cells.Copy ' 复制部门、工号、姓名
Sheet4.Select
Range("A1").Select
ActiveSheet.Paste ' 粘贴
Range("A1").Select
Cells.Interior.ColorIndex = xlNone ' 所有单元格颜色取消
'---
x4 = 2
Do While Not (IsEmpty(Sheet4.Cells(x4, 3).Value)) ' 在表6中寻找姓名
If Sheet4.Cells(x4, 4).Value = "正班" Then
For y = 1 To 31
minsj = ""
maxsj = ""
c_sj = Sheet4.Cells(x4, y + 4).Value
If InStr(1, c_sj, ":", 1) = 0 Then
Sheet4.Cells(x4, y + 4).Interior.ColorIndex = 8 ' 6-黄色，34－兰色
Else
If InStr(1, c_sj, Chr(10), 0) = 0 Then
Sheet4.Cells(x4, y + 4).Value = "打卡1次"
Sheet4.Cells(x4, y + 4).Interior.ColorIndex = 34 ' 6-黄色，34－兰色
Else
minsj = Split(c_sj, Chr(10))(0)
maxsj = Split(c_sj, Chr(10))(1)
xs = Hour(maxsj) - Hour(minsj) - 1 ' 减中午11:30--13:00的时间之1小时
fz = Minute(maxsj) - Minute(minsj) - 30 ' 减中午11:30--13:00的时间之30分钟
If fz < 0 Then ' 分钟为负数，需要借1小时，化为分钟
xs = xs - 1
fz = fz + 60
End If
Sheet4.Cells(x4, y + 4).Value = xs & "时" & fz & "分"
End If
End If
Next y
Sheet4.Cells(x4, 4).Interior.ColorIndex = 8
Else ' 以下计算加班
For y = 1 To 31
minsj = ""
maxsj = ""
c_sj = Sheet4.Cells(x4, y + 4).Value
If InStr(1, c_sj, ":", 1) = 0 Or InStr(1, c_sj, " ", 1) <> 0 Then 'InStr(1, Sheet3.Cells(x3, y + 4).Value, ":", 1) <> 0
Sheet4.Cells(x4, y + 4).Interior.ColorIndex = 6 ' 6-黄色，34－兰色
Else
If InStr(1, c_sj, Chr(10), 0) = 0 Then
Sheet4.Cells(x4, y + 4).Value = "打卡1次"
Sheet4.Cells(x4, y + 4).Interior.ColorIndex = 34 ' 6-黄色，34－兰色
Else
minsj = Split(c_sj, Chr(10))(0)
maxsj = Split(c_sj, Chr(10))(1)
xs = Hour(maxsj) - Hour(minsj)
fz = Minute(maxsj) - Minute(minsj)
If fz < 0 Then ' 分钟为负数，需要借1小时，化为分钟
xs = xs - 1
fz = fz + 60
End If
Sheet4.Cells(x4, y + 4).Value = xs & "时" & fz & "分"
End If
End If
Next y
Sheet4.Cells(x4, 4).Interior.ColorIndex = 6
End If
x4 = x4 + 1
Loop
End Sub
因公司电脑有加密，所以附件不发上来了 |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-26 09:34
楼主
