求高手帮忙，排班表统计工作小时及每个小时工作的人数及名单

iddzj

附件中是一个排班表，想统计
1、在17行中，统计每天aa-mm员工的工作小时数。
2、在I列中，统计每个员工一周的工作小时数。
3、在后面那个表中，统计每个时间段有几个员工工作，他们的名字是什么。

求高手帮忙，谢谢了！

李甲

这个看来要代码了                     

sunya_0529

这个需求用函数显然很难满足了。就事论事地用代码解决——

第一个需求，统计工作小时合计，做一个简单的自定义函数：

1. Function hsum(rng As Range)
   
2. On Error Resume Next
   
3. Dim k As Range, arr, d!
   
4. If rng Is Nothing Then Exit Function
   
5. For Each k In rng
   
6.   If Len(k) > 0 Then
   
7.     arr = Split(k, "-")
   
8.     d = d + Hour(CDate(arr(1)) - CDate(arr(0))) + Minute(CDate(arr(1)) - CDate(arr(0))) / 60
   
9.   End If
   
10. Next
    
11. hsum = Round(d, 2)
    
12. End Function

复制代码

第二个需求，用一个宏解决，报表生成在“Sheet2"，用了太多循环，算法没优化，数据量大的情况下，可能运算时间长：

1. Sub report()
   
2. On Error Resume Next
   
3. Dim k As Range, i%, m%, arr(1 To 9999, 1 To 4)
   
4. '获取数据清单
   
5. With Sheet1
   
6.   For Each k In Range(.Cells(3, 1), .Cells(.[A65536].End(xlUp).Row, 1))
   
7.     For i = 1 To 7
   
8.       If Len(.Cells(k.Row, i + 1)) > 0 And Not IsNumeric(.Cells(k.Row, i + 1)) Then
   
9.         m = m + 1
   
10.         arr(m, 1) = k.Value
    
11.         arr(m, 2) = Application.Text(i, "dddd")
    
12.         arr(m, 3) = CDate(Split(.Cells(k.Row, i + 1), "-")(0))
    
13.         arr(m, 4) = CDate(Split(.Cells(k.Row, i + 1), "-")(1))
    
14.       End If
    
15.     Next i
    
16.   Next
    
17. End With
    
18. '提炼生成报表
    
19. Dim arrR(1 To 18, 1 To 15), j%, x%, a%, b$
    
20. For i = 1 To 16
    
21.   arrR(i + 2, 1) = Format(5 + i, "00") & ":00-" & Format(6 + i, "00") & ":00" '写入左标题
    
22.   For j = 2 To 14 Step 2
    
23.     '写入顶端标题
    
24.     arrR(1, j) = Application.Text(j / 2, "dddd")
    
25.     arrR(2, j) = "员工数"
    
26.     arrR(2, j + 1) = "员工名单"
    
27.     '查询数据
    
28.     a = 0
    
29.     b = ""
    
30.     For x = 1 To m
    
31.       If arr(x, 2) = Application.Text(j / 2, "dddd") And Hour(arr(x, 3)) <= i + 5 And Hour(arr(x, 4)) >= i + 6 Then
    
32.         a = a + 1
    
33.         b = b & arr(x, 1) & ","
    
34.       End If
    
35.     Next
    
36.     arrR(i + 2, j) = a
    
37.     arrR(i + 2, j + 1) = Left(b, Len(b) - 1)
    
38.   Next
    
39. Next
    
40. '写入最终报表
    
41. With Sheet2
    
42.   .Cells.ClearContents
    
43.   .[A1].Resize(18, 15) = arrR
    
44. End With
    
45. End Sub

复制代码

具体效果看附件吧，不啰嗦了！

iddzj

sunya_0529 发表于 2013-12-19 16:44
这个需求用函数显然很难满足了。就事论事地用代码解决——

第一个需求，统计工作小时合计，做一个简单的 ...

谢谢，真是太有帮助了！