'参与一下,源数据可能有些问题,,,
Option Explicit
Sub test()
Dim arr, i, j, dic(1), m, n, a, b
For i = 0 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
arr = Sheets("3行政").[a1].CurrentRegion.Offset(1)
For i = 1 To UBound(arr, 1) - 1
If Not dic(0).exists(arr(i, 2)) Then
n = n + 1
dic(0)(arr(i, 2)) = n + 2
End If
If Not dic(1).exists(arr(i, 11)) Then
m = m + 2
dic(1)(arr(i, 11)) = m
End If
Next
ReDim brr(1 To m + 2, 1 To n + 2)
For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
If arr(j, 2) <> arr(j + 1, 2) Then
brr(1, dic(0)(arr(i, 2))) = arr(i, 2)
For a = i To j
If arr(a, 22) = "上午" Then
brr(dic(1)(arr(a, 11)), 1) = arr(a, 11)
brr(dic(1)(arr(a, 11)), 2) = "上午"
brr(dic(1)(arr(a, 11)) + 1, 2) = "下午"
For b = a To UBound(arr, 1) - 1
If arr(b + 1, 22) <> "上午" Or arr(b, 11) <> arr(b + 1, 11) Then Exit For
Next
brr(dic(1)(arr(a, 11)), dic(0)(arr(i, 2))) = b - a + 1
If a <> b Then a = b
End If
If arr(a, 22) = "下午" Then
brr(dic(1)(arr(a - 1, 11)), 1) = arr(a, 11)
brr(dic(1)(arr(a, 11)), 2) = "上午"
brr(dic(1)(arr(a, 11)) + 1, 2) = "下午"
For b = a To UBound(arr, 1) - 1
If arr(b + 1, 22) <> "下午" Or arr(b, 11) <> arr(b + 1, 11) Then Exit For
Next
brr(dic(1)(arr(a, 11)) + 1, dic(0)(arr(i, 2))) = b - a + 1
If a <> b Then a = b
End If
Next
i = j: Exit For
End If
Next j, i
For i = 2 To UBound(brr, 1)
If Len(brr(i, 2)) Then
For j = 3 To UBound(brr, 2)
If Len(brr(i, j)) = 0 Then brr(i, j) = "缺勤"
Next
End If
Next
Sheets("行政打卡次数统计").[a1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub |