考勤表的分析统计

zyq12688

          开始接手考勤分析事务，机器只能导出这样的数据，怎样分析出考勤结果是件头疼的事情。还请高手多多帮忙！

只要分析工作日的考勤结果，上午7：00到9：30即到班，下午14：30到16：00进行考勤即到班，周一只考勤下午。要有每个工号每个工作日的到班汇总表，表中要用红色实圆标出未到班情况。

哈喽哈哈1

一看这个表格就是从钉钉里面导出来的。我也遇见过这样的事情

哈喽哈哈1

有没有你之前汇总过的附件发一下，按照你的要求进行操作，你讲的有点不清楚

zyq12688

哈喽哈哈1 发表于 2024-10-19 14:30
有没有你之前汇总过的附件发一下，按照你的要求进行操作，你讲的有点不清楚

真的不好意思，一切从头开始，这是上面的意思。

不过我估计是这样的

Qs18

1. Sub qs() '2024/10/19
   
2. Application.ScreenUpdating = False
   
3. Dim arr, i
   
4. arr = Sheet2.Range("a1").CurrentRegion.Value
   
5. brr = Sheet2.Range("a1").CurrentRegion.Value
   
6. st1 = TimeValue("7:00"): st2 = TimeValue("9:30")
   
7. xt1 = TimeValue("14:30"): xt2 = TimeValue("16:30")
   
8. For i = 3 To UBound(arr)
   
9.     For j = 3 To UBound(arr, 2)
   
10.         If arr(i, j) = "" Then
    
11.             brr(i, j) = "未到班"
    
12.         Else
    
13.             If arr(2, j) = "一" Then
    
14.                 b = Split(arr(i, j), Chr(10))
    
15.                 For x = 0 To UBound(b)
    
16.                     If Len(b(x)) > 0 Then
    
17.                         If TimeValue(b(x)) > xt2 Then brr(i, j) = "未到班" Else brr(i, j) = "到班"
    
18.                     End If
    
19.                 Next
    
20.             
    
21.             Else
    
22.                 a = Split(arr(i, j), Chr(10))
    
23.                 For y = 0 To UBound(a)
    
24.                     k = 0: tb = ""
    
25.                     If Len(a(y)) > 0 Then
    
26.                         If TimeValue(a(y)) >= st1 And TimeValue(a(y)) <= st2 Then
    
27.                             tb = "上午到班"
    
28.                             k = k + 1
    
29.                             Exit For
    
30.                         End If
    
31.                     End If
    
32.                 Next
    
33.                 If k = 0 Then tb = "未到班"
    
34.                 For y = 0 To UBound(a)
    
35.                     k = 0: tb2 = ""
    
36.                     If Len(a(y)) > 0 Then
    
37.                         If TimeValue(a(y)) >= xt1 And TimeValue(a(y)) <= xt2 Then
    
38.                             tb2 = "下午到班"
    
39.                             k = k + 1
    
40.                             Exit For
    
41.                         End If
    
42.                     End If
    
43.                 Next
    
44.                 If k = 0 Then tb2 = "未到班"
    
45.                 brr(i, j) = tb & Chr(10) & tb2
    
46.             End If
    
47.     End If
    
48.     Next j
    
49. Next
    
50. Sheet2.Range("AF1").Resize(10000, 100) = Empty
    
51. Sheet2.Range("AF1").Resize(UBound(arr), UBound(arr, 2)) = brr
    
52. Dim rng As Range, rn As Range
    
53. Set rng = Sheet2.Range("af1").CurrentRegion
    
54. For Each rn In rng
    
55.    
    
56. ta = InStr(rn.Value, "未到班")
    
57. If ta > O Then
    
58. 'MsgBox ta
    
59. rn.Characters(ta, ta + 2).Font.Color = vbRed
    
60. End If
    
61. Next
    
62. Application.ScreenUpdating = True
    
63. End Sub
    

复制代码

Qs18

试试...........

Qs18

1. Sub qs() '2024/10/19
   
2. Application.ScreenUpdating = False
   
3. Dim arr, i
   
4. arr = Sheet2.Range("a1").CurrentRegion.Value
   
5. brr = Sheet2.Range("a1").CurrentRegion.Value
   
6. st1 = TimeValue("7:00"): st2 = TimeValue("9:30")
   
7. xt1 = TimeValue("14:30"): xt2 = TimeValue("16:30")
   
8. For i = 3 To UBound(arr)
   
9.     For j = 3 To UBound(arr, 2)
   
10.         If arr(i, j) = "" Then
    
11.             brr(i, j) = "未到班"
    
12.         Else
    
13.             If arr(2, j) = "一" Then
    
14.                 b = Split(arr(i, j), Chr(10))
    
15.                 For x = 0 To UBound(b)
    
16.                     If Len(b(x)) > 0 Then
    
17.                         If TimeValue(b(x)) > xt2 Then brr(i, j) = "未到班" Else brr(i, j) = "到班"
    
18.                     End If
    
19.                 Next
    
20.             
    
21.             Else
    
22.                 a = Split(arr(i, j), Chr(10))
    
23.                 For y = 0 To UBound(a)
    
24.                     k = 0: tb = ""
    
25.                     If Len(a(y)) > 0 Then
    
26.                         If TimeValue(a(y)) >= st1 And TimeValue(a(y)) <= st2 Then
    
27.                             tb = "上午到班"
    
28.                             k = k + 1
    
29.                             Exit For
    
30.                         End If
    
31.                     End If
    
32.                 Next
    
33.                 If k = 0 Then tb = "未到班"
    
34.                 For y = 0 To UBound(a)
    
35.                     k = 0: tb2 = ""
    
36.                     If Len(a(y)) > 0 Then
    
37.                         If TimeValue(a(y)) >= xt1 And TimeValue(a(y)) <= xt2 Then
    
38.                             tb2 = "下午到班"
    
39.                             k = k + 1
    
40.                             Exit For
    
41.                         End If
    
42.                     End If
    
43.                 Next
    
44.                 If k = 0 Then tb2 = "未到班"
    
45.                 brr(i, j) = tb & Chr(10) & tb2
    
46.             End If
    
47.     End If
    
48.     Next j
    
49. Next
    
50. Sheet2.Range("AF1").Resize(10000, 100) = Empty
    
51. Sheet2.Range("AF1").Resize(10000, 100).Font.ColorIndex = xlAutomatic
    
52. Sheet2.Range("AF1").Resize(UBound(arr), UBound(arr, 2)) = brr
    
53. Dim rng As Range, rn As Range
    
54. Set rng = Sheet2.Range("af1").CurrentRegion
    
55. For Each rn In rng
    
56.    
    
57. ta = InStr(rn.Value, "未到班")
    
58. If ta > O Then
    
59. 'MsgBox ta
    
60. rn.Characters(ta, ta + 2).Font.Color = vbRed
    
61. End If
    
62. Next
    
63. Application.ScreenUpdating = True
    
64. End Sub
    

复制代码

Qs18

试试.............

Qs18

试试...........

shiruiqiang

大致结果可以，就是细节判断几句就行

正则处理一下。