计算时间

风雨相随3

Sub 出勤()
Dim Arr, Brr, i%, WT%, wD$, x%, y&, wDa&, wDe&, wdi&, wDee&
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Arr = Sheets("出勤时间").[a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To 100)
x = 1: y = 2
For i = 2 To UBound(Arr)
WT = Arr(i, 6) + Arr(i, 7) + Arr(i, 8) + Arr(i, 9)
'wDa = Day(Arr(i, 1))
'wDe = WorksheetFunction.Weekday(Arr(i, 1), 2)
'wDee = WorksheetFunction.Weekday(Arr(i, 1) - wDa + 1, 2)
'wdi = Int(((wDa - 1) / 7) + 1 + (wDee > wDe) * 1)
'wD = "第" & wdi & "周"
wD = "第" & Week(Arr(i, 1)) & "周"
If Not Dic.exists(wD) Then
y = y + 1
Dic(wD) = y
Brr(1, y) = wD
End If
If Not Dic.exists(Arr(i, 2)) Then
x = x + 1

Dic(Arr(i, 2)) = x
Brr(x, 1) = Arr(i, 2): Brr(x, 2) = Arr(i, 3)
Brr(x, Dic(wD)) = WT


Else
Brr(Dic(Arr(i, 2)), Dic(wD)) = Brr(Dic(Arr(i, 2)), Dic(wD)) + WT
End If
Next i
Brr(1, 2) = "姓名"
Brr(1, 1) = "工号"
With Sheets("汇算")
.Cells.ClearContents
.[a1].Resize(x, y) = Brr
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

Function Week(Tag)
Week = VBA.DatePart("ww", Tag, vbMonday, vbFirstFourDays)
End Function

完美解决，感谢诸位大神！！！！！！！！

YZC51

学习楼主的代码。谢谢!
Sub 出勤()
    Dim Arr, Brr, i%, WT%, wD$, x%, y&, wDa&, wDe&, wdi&, wDee&
    Set Dic = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Arr = Sheets("出勤时间").[a1].CurrentRegion
    ReDim Brr(1 To UBound(Arr), 1 To 100)
    x = 1: y = 2
    For i = 2 To UBound(Arr)
        WT = Arr(i, 6) + Arr(i, 7) + Arr(i, 8) + Arr(i, 9)
        wD = "第" & Format(Arr(i, 1) - 1, "ww") & "周"
        If Not Dic.exists(wD) Then
            y = y + 1
            Dic(wD) = y
            Brr(1, y) = wD
        End If
        If Not Dic.exists(Arr(i, 2)) Then
            x = x + 1
            Dic(Arr(i, 2)) = x
            Brr(x, 1) = Arr(i, 2): Brr(x, 2) = Arr(i, 3)
            Brr(x, Dic(wD)) = WT
        Else
            Brr(Dic(Arr(i, 2)), Dic(wD)) = Brr(Dic(Arr(i, 2)), Dic(wD)) + WT
        End If
    Next i
    Brr(1, 2) = "姓名"
    Brr(1, 1) = "工号"
    With Sheets("汇算")
        .Cells.ClearContents
        .[a1].Resize(x, y) = Brr
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
End Sub

风雨相随3

如果要写入Brr （1，3）=“部门”该改那些地方?

风雨相随3

Sub 出勤()
Dim Arr, Brr, i%, WT%, wD$, x%, y&, wDa&, wDe&, wdi&, wDee&
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Arr = Sheets("出勤时间").[a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To 100)
x = 1: y = 3
For i = 2 To UBound(Arr)
WT = Arr(i, 6) + Arr(i, 7) + Arr(i, 8) + Arr(i, 9)
'wDa = Day(Arr(i, 1))
'wDe = WorksheetFunction.Weekday(Arr(i, 1), 2)
'wDee = WorksheetFunction.Weekday(Arr(i, 1) - wDa + 1, 2)
'wdi = Int(((wDa - 1) / 7) + 1 + (wDee > wDe) * 1)
'wD = "第" & wdi & "周"
wD = "第" & Week(Arr(i, 1)) & "周"
If Not Dic.exists(wD) Then
y = y + 1
Dic(wD) = y
Brr(1, y) = wD
End If
If Not Dic.exists(Arr(i, 2)) Then
x = x + 1

Dic(Arr(i, 2)) = x
Brr(x, 1) = Arr(i, 2): Brr(x, 2) = Arr(i, 3): Brr(x, 3) = Arr(i, 4)
Brr(x, Dic(wD)) = WT


Else
Brr(Dic(Arr(i, 2)), Dic(wD)) = Brr(Dic(Arr(i, 2)), Dic(wD)) + WT
End If
Next i
Brr(1, 2) = "姓名"
Brr(1, 1) = "工号"
Brr(1, 3) = "部门"
With Sheets("汇算")
.Cells.ClearContents
.[a1].Resize(x, y) = Brr
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

'无需加载分析工具!
Function Week(Tag)
Week = VBA.DatePart("ww", Tag, vbMonday, vbFirstFourDays)
End Function