如何把同一姓名、不同日期、不在一行的考勤时间做到同一行当中

zhuxs

如何把同一姓名、不同日期、不在一行的考勤时间做到同一行当中请大神帮忙！

sdong7

1. Sub tt() 'by sdong7 20141101
   
2. Dim mxr As Long
   
3. Dim arr, dic, dic2, arr1(1 To 50000, 1 To 16), arr2(1 To 50000, 1 To 9)
   
4. 
   
5. Dim st As String
   
6. 
   
7. mxr = Sheets("打卡机导出的原始数据").[a65536].End(xlUp).Row
   
8. arr = Sheets("打卡机导出的原始数据").Range("a1:i" & mxr)
   
9. Set dic = CreateObject("scripting.dictionary")
   
10. Set dic2 = CreateObject("scripting.dictionary")
    
11. On Error Resume Next
    
12. '去除重复打卡小时以内
    
13. For i = 2 To mxr
    
14. st = arr(i, 2) & arr(i, 9) & Left(arr(i, 4), 16)
    
15. If dic2.exists(st) Then
    
16. hang = dic2(st)
    
17. arr2(hang, 4) = arr(i, 4)
    
18. Else
    
19. k2 = k2 + 1
    
20. dic2(st) = k2
    
21. For n = 1 To 9
    
22. arr2(k2, n) = arr(i, n)
    
23. Next n
    
24. End If
    
25. Next i
    
26. 
    
27. 
    
28. 
    
29. 
    
30. 
    
31. 
    
32. For i = 1 To k2
    
33. st = arr2(i, 2) & arr2(i, 9) & Left(arr2(i, 4), 10)
    
34. If dic.exists(st) Then
    
35. hang = dic(st)
    
36. arr1(hang, 4) = arr1(hang, 4) & "?" & Right(arr2(i, 4), 8)
    
37. 
    
38. Else
    
39. k = k + 1
    
40. dic(st) = k
    
41. arr1(k, 1) = arr2(i, 2)
    
42. arr1(k, 2) = arr2(i, 9)
    
43. arr1(k, 3) = Left(arr2(i, 4), 10)
    
44. arr1(k, 4) = Right(arr2(i, 4), 8)
    
45. End If
    
46. Next i
    
47. 
    
48. For i = 1 To k
    
49. gg = 2
    
50. 
    
51. 
    
52. larr = Split(arr1(i, 4), "?")
    
53. t = UBound(larr, 1)
    
54. 
    
55. For j = 0 To t
    
56. 
    
57. 
    
58. arr1(i, 2 + gg) = larr(j)
    
59. gg = gg + 1
    
60. 
    
61. 
    
62. Next j
    
63. 
    
64. Next i
    
65. 
    
66. Sheets("打卡机导出的原始数据").[p2].Resize(k, 16) = arr1
    
67. End Sub
    

复制代码

sdong7

如果觉得好就送朵鲜花！！！

sdong7

上传附件！！！！！！！

sdong7

动了些脑筋，今天看了论坛中的字典的另一种用法才想起字典居然可以这么用

sdong7

千万别吝啬鲜花哦！！！！！

sunya_0529

sdong7 发表于 2014-11-1 13:31
千万别吝啬鲜花哦！！！！！

作为新任版主，代表论坛感谢你的积极参与和分享，希望我们一起努力，将HR版块的学习氛围带动起来。

建议不要多次刷回复，我们回的帖子重质不重量，按下来对于负责任、有内容、有创新等的回帖都将给予一定的财富奖励，当然，对于恶意灌水的也将给予处分，以维护论坛的健康发展。

回到楼主的这个问题，你的字典解决方案思路不错，代码执行效率也较快。只是对于报表结果的输出上，需要再下点功夫。

下面是我用常规的方法写的代码，供你和楼主参考——

1. Option Explicit
   
2. 
   
3. Sub ShowReport()
   
4. On Error Resume Next '错误处理
   
5. Dim k As Range, arrR(1 To 9999, 5), n$, d As Date, t As Date, i&, n1$, d1 As Date, t1 As Date
   
6. With ActiveSheet
   
7.   .[P2:U9999].ClearContents '清空结果显示区域
   
8.   For Each k In .Range("C2:C" & .[C2].End(xlDown).Row)
   
9.     n = k.Value '获取当前记录的登记号码
   
10.     d = CDate(Left(k.Offset(0, 1), 10)) '获取当前记录的日期
    
11.     t = CDate(Right(k.Offset(0, 1), 8))  '获取当前记录的时间
    
12.     If InStr(k.Offset(0, 1), "下午") > 0 And CInt(Mid(k.Offset(0, 1), 15, 2)) <> 12 Then t = t + TimeSerial(12, 0, 0)
    
13.     If n <> n1 Then
    
14.       i = i + 1
    
15.       arrR(i, 0) = k.Offset(0, -1).Value '姓名
    
16.       arrR(i, 1) = k.Offset(0, 6).Value '打卡方式
    
17.       arrR(i, 2) = d '日期
    
18.       arrR(i, 3) = t '签到时间1
    
19.     Else
    
20.       If d = d1 Then
    
21.         If t - t1 > TimeSerial(0, 30, 0) Then
    
22.           Select Case k.Offset(0, 6).Value
    
23.             Case "生产"
    
24.               If t < TimeSerial(20, 0, 0) Then arrR(i, 4) = t '签到时间2
    
25.             Case "清洁工"
    
26.               If t < TimeSerial(16, 0, 0) Then arrR(i, 4) = t
    
27.             Case "办公室"
    
28.               If t < TimeSerial(13, 0, 0) Then arrR(i, 4) = t
    
29.           End Select
    
30.         End If
    
31.         arrR(i, 5) = t '签到时间3
    
32.         If t - arrR(i, 3) < TimeSerial(0, 30, 0) Or t - arrR(i, 4) < TimeSerial(0, 30, 0) Then arrR(i, 5) = ""
    
33.       Else
    
34.         i = i + 1
    
35.         arrR(i, 0) = k.Offset(0, -1).Value '姓名
    
36.         arrR(i, 1) = k.Offset(0, 6).Value '打卡方式
    
37.         arrR(i, 2) = d '日期
    
38.         arrR(i, 3) = t '签到时间1
    
39.       End If
    
40.     End If
    
41.     n1 = n '储存上条记录的登记号码
    
42.     d1 = d '储存上条记录的日期
    
43.     t1 = t '储存上条记录的时间
    
44.   Next
    
45.   .[P2].Resize(UBound(arrR), 6) = arrR
    
46. End With
    
47. End Sub
    

复制代码