打卡记录整理VBA

三分醉，七分醒

试试这个看              

Jerry谭悦

很久以前搞过一次，主要难点：
1，姓名没有唯一ID，重名不好处理。（需要考勤系统支持）
2，各公司对第二日的规则较多，例如：前一日加班第二日抵扣等很多情况。
其他都比较简单，所以原来的思路：1,是先做基础计算统计，2,也就是您这个第二张表，3,然后再做人工处理（VBA主要提供异常标注，手动修改）.4,输出人力格式考勤表（做薪用）。

gemeng25569

3190496160 发表于 2023-4-30 09:28

谢谢你的帮忙，及感谢其它朋友，已经弄好了，我自己添加公式弄好了，字典我看得头晕

        
        Dim x, y, z, p As Range
        Set x = Worksheets("考勤数据").Range("B2:B" & ra) '日期
        Set y = Worksheets("考勤数据").Range("C2:C" & ra) '姓名
        Set z = Worksheets("考勤数据").Range("D2:D" & ra) '时间
        Set p = Range("D2")
        For k = 4 To Range("D2").End(xlToRight).Column
        Worksheets("员工考勤表").Cells(i - 2, k) = Application.MinIfs([z], [x], Cells(2, k), [y], Range("A" & i))
        Worksheets("员工考勤表").Cells(i - 1, k) = Application.MaxIfs([z], [x], Cells(2, k), [y], Range("A" & i))
        Worksheets("员工考勤表").Cells(i - 2, k).NumberFormatLocal = "h:mm;@"
        Worksheets("员工考勤表").Cells(i - 1, k).NumberFormatLocal = "h:mm;@"
        'Cells(i, 5) = itm
        Worksheets("员工考勤表").Cells(i - 1, 2) = WorksheetFunction.CountA(Range(Cells(i - 1, 4), Cells(i - 1, 34)))
        Worksheets("员工考勤表").Cells(i, 2) = WorksheetFunction.Sum(Range(Cells(i, 4), Cells(i, 34)))
        

gemeng25569

3190496160 发表于 2023-4-30 13:56
日期是4月2日，打卡日期又是4月6日，我不知道你的数据究竟是不是真实的数据

是我没注意前面的日期，谢谢你

3190496160

Sub 考勤统计()
Application.ScreenUpdating = False
Dim ar As Variant, arr As Variant
Dim d As Object, dc As Object
Dim br()
Dim sMax As String, sMin As String, sTime As String
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("考勤数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考勤数据为空！": End
    .Range("a1:d" & r).Sort .[c1], 1, , , , , , 1 '
    ar = .Range("a1:d" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 2)) <> "" And Trim(ar(i, 3)) <> "" Then
        zd = Trim(ar(i, 2)) & "|" & Trim(ar(i, 3))
        d(zd) = ""
    End If
Next i
With Sheets("员工考勤表")
    .UsedRange.Offset(3).Clear
    arr = .Range("a2:ah" & r)
    k = 2
    For Each kk In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To 1)
        d.RemoveAll: sMin = "A"
        For i = 2 To UBound(ar)
            If Trim(ar(i, 2)) <> "" And Trim(ar(i, 3)) <> "" Then
                zd = Trim(ar(i, 2)) & "|" & Trim(ar(i, 3))
                If zd = kk Then
                    n = n + 1
                    br(n, 1) = TimeValue(CDate(Format(ar(i, 4), "h:mm:ss")))
                End If
            End If
        Next i
        For i = 1 To n
            For s = i + 1 To n
                If br(i, 1) > br(s, 1) Then
                    mk = br(i, 1)
                    br(i, 1) = br(s, 1)
                    br(s, 1) = mk
                End If
            Next s
        Next i
        rr = Split(kk, "|")
        xm = Trim(rr(1))
        t = dc(xm)
        If t = "" Then
            k = k + 3
            dc(xm) = k
            t = k
            arr(k, 1) = xm
            arr(k - 2, 2) = "天数/总工时h"
            arr(k - 2, 3) = "签到"
            arr(k - 1, 3) = "签退"
            arr(k, 3) = "工时"
        End If
        lh = Day(rr(0))
        arr(t - 2, lh + 3) = br(1, 1)
        arr(t - 1, lh + 3) = br(n, 1)
        .Range("D" & t - 1).Resize(1, 31).NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"
        .Range("D" & t).Resize(1, 31).NumberFormatLocal = "[$-x-systime]h:mm:ss AM/PM"
        arr(t, lh + 3) = (arr(t - 1, lh + 3) - arr(t - 2, lh + 3)) * 24
        .Range("b" & t + 1).Resize(1, 33).NumberFormatLocal = "0.0_ "
    Next kk
    For i = 4 To k Step 3
        hj = 0: zj = 0
        For j = 4 To UBound(arr, 2)
            If Trim(arr(i, j)) <> "" Then
                hj = hj + 1
            End If
            zj = zj + arr(i + 1, j)
        Next j
        arr(i, 2) = hj
        arr(i + 1, 2) = zj
    Next i
    .[a2].Resize(k, UBound(arr, 2)) = arr
    .[a2].Resize(k, UBound(arr, 2)).Borders.LineStyle = 1
End With
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

增加了合计
考勤表.rar (38.59 KB, 下载次数: 15)

2023-4-30 18:19 上传

点击文件名下载附件

xunanming

参与练手一下...............................

gemeng25569

xunanming 发表于 2023-5-2 03:38
参与练手一下...............................

练手也得测试一下哈

沈默00

过来学习下，之前也碰到这样的问题

gemeng25569

3190496160 发表于 2023-4-30 18:19
增加了合计

感谢你帮助，很厉害，运行速度很快