请大神帮忙把下面考勤的表提取一下

菜海遨游

新建个工作表提取部门、工号、姓名、早上打卡的最早时间、晚上打卡的最晚时间，谢谢

不知道为什么

真就纳闷了，现在还有什么样的公司考勤还要用这样的表格？没有系统？再说你要输出什么样的结果倒给模拟下啊？

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
8.     If r Mod 2 = 1 Then
   
9.       r = r + 1
   
10.     End If
    
11.     arr = .Range("a3:ae" & r)
    
12.   End With
    
13.   For i = 3 To UBound(arr) Step 2
    
14.     If Not d.exists(arr(i, 3)) Then
    
15.       ReDim brr(1 To 34)
    
16.       brr(1) = arr(i, 21)
    
17.       brr(2) = arr(i, 3)
    
18.       brr(3) = arr(i, 11)
    
19.     Else
    
20.       brr = d(arr(i, 3))
    
21.     End If
    
22.     For j = 1 To UBound(arr, 2)
    
23.       If Len(arr(i + 1, j)) <> 0 Then
    
24.         sj1 = Left(arr(i + 1, j), 5)
    
25.         sj2 = Right(arr(i + 1, j), 5)
    
26.         If sj1 = sj2 Then
    
27.           brr(j + 3) = sj1
    
28.         Else
    
29.           brr(j + 3) = sj1 & vbLf & sj2
    
30.         End If
    
31.       End If
    
32.     Next
    
33.     d(arr(i, 3)) = brr
    
34.   Next
    
35.   With Worksheets("sheet2")
    
36.     .UsedRange.Offset(1, 0).ClearContents
    
37.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
38.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
39.     .Range("a1:ag" & r).Borders.LineStyle = xlContinuous
    
40.   End With
    
41. End Sub
    

复制代码

chxw68

楼主连个结果表样式也不给，猜测着写的，供参考。

opiona

1.     Set SHK = Worksheets("考勤表")
   
2.     Set SHJ = Worksheets("结果")
   
3.     SHJ.Range("A2:AZ1048576").ClearContents
   
4.    
   
5.     X = 1
   
6.     For I = 5 To SHK.Range("A1048576").End(3).Row
   
7.         If InStr(Replace(SHK.Cells(I, 1).Value, " ", ""), "工号") > 0 Then
   
8.             Rem  提示信息，在状态栏显示
   
9.             Application.StatusBar = "当前姓名是：" & SHK.Cells(I, 11).Value
   
10.             DoEvents
    
11.             
    
12.             X = X + 1
    
13.             SHJ.Cells(X, 1).Value = SHK.Cells(I, 21).Value
    
14.             SHJ.Cells(X, 2).Value = SHK.Cells(I, 3).Value
    
15.             SHJ.Cells(X, 3).Value = SHK.Cells(I, 11).Value
    
16.             
    
17.             For ICOL = 1 To 31
    
18.                 If SHK.Cells(I + 1, ICOL).Value <> "" Then
    
19.                     A = SHK.Cells(I, ICOL).Value
    
20.                     STRX = GetRegStr(SHK.Cells(I + 1, ICOL).Value, "[0-9]{2,2}[:][0-9]{2,2}", 0)
    
21.                     ARX = Split(STRX, "|")
    
22.                     STRX = ARX(0)
    
23.                     If UBound(ARX) > 0 Then
    
24.                         STRX = STRX & vbCrLf & ARX(UBound(ARX))
    
25.                     End If
    
26.                     
    
27.                     SHJ.Cells(X, ICOL + 3).Value = STRX
    
28.                 End If
    
29.             Next
    
30.         End If
    
31.     Next

复制代码

opiona

QQ14885553.rar (44.38 KB, 下载次数: 5)

2018-7-12 09:08 上传

点击文件名下载附件

菜海遨游

opiona 发表于 2018-7-12 09:09

能把打卡的最早时间和最晚时间分两个单元格放么

不知道为什么

菜海遨游 发表于 2018-7-12 18:48
能把打卡的最早时间和最晚时间分两个单元格放么

给新人点提示啊：首先要学会和老师的互动，最基础的方式就是点击评分！这也是对别人付出的尊重！

opiona

菜海遨游 发表于 2018-7-12 18:48
能把打卡的最早时间和最晚时间分两个单元格放么

这年月，义工也不好做啊，哈哈
老板已经修改，您看，还满意么？
有什么问题，我马上改！

小红花就不敢提了，别扔鸡蛋就好，嘻嘻！！！！
QQ14885553.rar (49.4 KB, 下载次数: 3)

2018-7-12 20:16 上传

点击文件名下载附件

菜海遨游

不知道为什么 发表于 2018-7-12 19:08
给新人点提示啊：首先要学会和老师的互动，最基础的方式就是点击评分！这也是对别人付出的尊重！

哈哈，明白，谢谢老师