考勤机打卡时间提取问题求助

电鳗01

上午8点到11点，下午15点到17点是正常上班时间，一天正常打卡四次，6点半到9点半之前打卡算上午签到，9点半后到12点半打卡算上午签退；14点到16点打卡算下午签到，16点后到18点打卡算下午签退。现要把考勤机某一天的的考勤时间（表1）按前面要求提取到表2相应单元格，请各位大神帮忙。

电鳗01

无解吗？自己顶一个

liuxi001

写一维表应该更利于数据汇总，另外时间点也与楼主有点出入~~自己斟酌吧

1. Sub kqzl()
   
2.     ar = Sheet1.[a1].CurrentRegion
   
3.     ReDim cr(1 To Rows.Count, 1 To 7)
   
4.     For i = 6 To UBound(ar) Step 2
   
5.         For j = 1 To UBound(ar, 2)
   
6.             If ar(i, j) <> "" Then
   
7.                 k = k + 1
   
8.                 cr(k, 1) = k
   
9.                 cr(k, 2) = ar(i - 1, 2)
   
10.                 cr(k, 3) = Left(ar(3, 2), 8) & Format(ar(4, j), "00")
    
11.                 With CreateObject("vbscript.regexp")
    
12.                     .Global = True
    
13.                     .Pattern = "\d{2}:\d{2}"
    
14.                     Set mh = .Execute(ar(i, j))
    
15.                     For Each mat In mh
    
16.                         t = TimeValue(mat)
    
17.                         my_col = IIf(t <= 9.5 / 24, 1, IIf(t <= 12.5 / 24, 2, IIf(t <= 16 / 24, 3, 4))) + 3
    
18.                         cr(k, my_col) = t
    
19.                     Next
    
20.                 End With
    
21.             End If
    
22.         Next
    
23.     Next
    
24.     With Sheet3
    
25.         .Cells.ClearContents
    
26.         .[a1].Resize(1, UBound(cr, 2)) = [{"序号","工号","日期","上午签到","上午签退","下午签到","下午签退"}]
    
27.         .[a2].Resize(k, UBound(cr, 2)) = cr
    
28.     End With
    
29. End Sub

复制代码

考勤数据整理.zip (23.33 KB, 下载次数: 53)

2019-5-1 17:16 上传

点击文件名下载附件

电鳗01

感谢老师帮忙，只是对ⅤBA不太懂，若工号增加了，代码是否要改动，改哪里?还请老师指点，谢谢！

liuxi001

不需要改动，自适应，只要中间没有空行空列

电鳗01

liuxi001 发表于 2019-5-2 10:21
不需要改动，自适应，只要中间没有空行空列

在限定的时间范围内（比如一个周），能否让有工号的空行空列也显示相应考勤日期？老师辛苦了，五一小假期快乐！

liuxi001

直接提供一个完整的表格，模拟效果吧

电鳗01

liuxi001 发表于 2019-5-3 16:39
直接提供一个完整的表格，模拟效果吧

麻烦老师了，五四快乐

micch

1. =IFERROR(HLOOKUP(B$2,IF({1;0},LOOKUP(--MID(OFFSET(Sheet1!$A$4,$A3*2,LOOKUP(33,$A$1:B$1)-1),{1,7,13,19},5),--{"6:30","9:30","12:30","16:00"},$B$2:$E$2),MID(OFFSET(Sheet1!$A$4,$A3*2,LOOKUP(33,$A$1:B$1)-1),{1,7,13,19},5)),2,),"")

复制代码

B3，右拉下拉，我得是多无聊，才做这个题啊，真麻烦

liuxi001

电鳗01 发表于 2019-5-3 16:30
在限定的时间范围内（比如一个周），能否让有工号的空行空列也显示相应考勤日期？老师辛苦了，五一小假期 ...

是这个意思吗？满意请给两朵小花，谢谢！

1. Sub kqzl()
   
2.     r = Application.Max(6, Sheet1.Cells.Find("*", , , , 1, 2).Row)
   
3.     ar = Sheet1.Range("a1:ae" & r)
   
4.     riqi = Array(, 1, 2, 3, 9, 10, 11, 12, 15, 16, 17, 18, 19, 22, 23, 24, 25, 26, 28, 29, 30) '指定考勤日期
   
5.     ReDim cr(1 To Rows.Count, 1 To 7)
   
6.     For i = 6 To UBound(ar) Step 2
   
7.         For j = 1 To UBound(riqi)
   
8.             k = k + 1
   
9.             cr(k, 1) = k
   
10.             cr(k, 2) = ar(i - 1, 3)
    
11.             cr(k, 3) = Left(ar(3, 3), 8) & Format(ar(4, riqi(j)), "00")
    
12.             If ar(i, riqi(j)) <> "" Then
    
13.                 With CreateObject("vbscript.regexp")
    
14.                     .Global = True
    
15.                     .Pattern = "\d{2}:\d{2}"
    
16.                     Set mh = .Execute(ar(i, riqi(j)))
    
17.                     For Each mat In mh
    
18.                         t = TimeValue(mat)
    
19.                         my_col = IIf(t <= 9.5 / 24, 1, IIf(t <= 12.5 / 24, 2, IIf(t <= 16 / 24, 3, 4))) + 3
    
20.                         cr(k, my_col) = t
    
21.                     Next
    
22.                 End With
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     With Sheet3
    
27.         .Cells.ClearContents
    
28.         .[a1].Resize(1, UBound(cr, 2)) = [{"序号","工号","日期","上午签到","上午签退","下午签到","下午签退"}]
    
29.         .[a2].Resize(k, UBound(cr, 2)) = cr
    
30.     End With
    
31. End Sub

复制代码