[已解决]考勤表VBA计算，请教各位老师

goldwong

表中员工的打卡时间分布在不同的格子中需按样表统计，请帮忙，谢谢

最佳答案

月排行榜 / 总排行榜

dsmch

2015-4-18 13:26

1. Sub Macro1()
   
2. Dim arr, brr, br, d, d2, i&, h&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet3.Range("a1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To 9)
   
7. For i = 2 To UBound(arr)
   
8.     x = Split(arr(i, 4))
   
9.     d2(arr(i, 1)) = d2(arr(i, 1)) + 1
   
10.     If Not d.exists(arr(i, 1)) Then
    
11.         h = h + 1
    
12.         d(arr(i, 1)) = h
    
13.         brr(h, 1) = arr(i, 1)
    
14.         brr(h, 2) = arr(i, 2)
    
15.         brr(h, 3) = x(0)
    
16.         brr(h, 4) = x(1)
    
17.     Else
    
18.         brr(d(arr(i, 1)), d2(arr(i, 1)) + 3) = x(1)
    
19.     End If
    
20. Next
    
21. ReDim br(1 To h, 1 To 9)
    
22. For i = 1 To h
    
23.     For j = 1 To 4
    
24.         br(i, j) = brr(i, j)
    
25.     Next
    
26.     s = 4
    
27.     For j = 5 To 9
    
28.         If brr(i, j) <> "" Then
    
29.             If DateDiff("s", brr(i, j - 1), brr(i, j)) >= 1800 Then s = s + 1: br(i, s) = brr(i, j)
    
30.         End If
    
31.     Next
    
32. Next
    
33. Sheet2.Activate
    
34. [a1:i1] = Array("工号", "姓名", "日期", "时间1", "时间2", "时间3", "时间4", "时间5", "时间6")
    
35. Range("a2").Resize(h, 9) = br
    
36. End Sub

复制代码

跳转到最佳答案楼层

爱疯

sheet1里，A:F是什么，I:L是什么？
sheet3里，A1:D19是什么，a26:i31是什么？

goldwong

老师您好，SHEET1和SHEET2不用理会，是我忘删了，请只看SHEET3的内容，谢谢。

goldwong

sheet3里，A1:D19是打卡记录，a26:i31是想要得到的结果？麻烦老师

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, i&, h&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To 9)
   
7. For i = 2 To UBound(arr)
   
8.     x = Split(arr(i, 4))
   
9.     d2(arr(i, 1)) = d2(arr(i, 1)) + 1
   
10.     If Not d.exists(arr(i, 1)) Then
    
11.         h = h + 1
    
12.         d(arr(i, 1)) = h
    
13.         brr(h, 1) = arr(i, 1)
    
14.         brr(h, 2) = arr(i, 2)
    
15.         brr(h, 3) = x(0)
    
16.         brr(h, 4) = x(1)
    
17.     Else
    
18.         brr(d(arr(i, 1)), d2(arr(i, 1)) + 3) = x(1)
    
19.     End If
    
20. Next
    
21. Range("a33").Resize(h, 9) = brr
    
22. End Sub

复制代码

dsmch

………………

goldwong

谢谢老师，有一点我没讲清楚，运算结果的表需放在一个新SHEET中，且得到的时间至少相隔30分钟，再次麻烦了，谢谢

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, br, d, d2, i&, h&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet3.Range("a1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To 9)
   
7. For i = 2 To UBound(arr)
   
8.     x = Split(arr(i, 4))
   
9.     d2(arr(i, 1)) = d2(arr(i, 1)) + 1
   
10.     If Not d.exists(arr(i, 1)) Then
    
11.         h = h + 1
    
12.         d(arr(i, 1)) = h
    
13.         brr(h, 1) = arr(i, 1)
    
14.         brr(h, 2) = arr(i, 2)
    
15.         brr(h, 3) = x(0)
    
16.         brr(h, 4) = x(1)
    
17.     Else
    
18.         brr(d(arr(i, 1)), d2(arr(i, 1)) + 3) = x(1)
    
19.     End If
    
20. Next
    
21. ReDim br(1 To h, 1 To 9)
    
22. For i = 1 To h
    
23.     For j = 1 To 4
    
24.         br(i, j) = brr(i, j)
    
25.     Next
    
26.     s = 4
    
27.     For j = 5 To 9
    
28.         If brr(i, j) <> "" Then
    
29.             If DateDiff("s", brr(i, j - 1), brr(i, j)) >= 1800 Then s = s + 1: br(i, s) = brr(i, j)
    
30.         End If
    
31.     Next
    
32. Next
    
33. Sheet2.Activate
    
34. [a1:i1] = Array("工号", "姓名", "日期", "时间1", "时间2", "时间3", "时间4", "时间5", "时间6")
    
35. Range("a2").Resize(h, 9) = br
    
36. End Sub

复制代码

goldwong

谢谢老师