|
'只写了科室的
'如果没有单刷出现(就是忘刷),白班、夜班可以判断。而实际情况是会出现的,所以没有办法给你写
Option Explicit
Sub test()
Dim arr, tm, i, j, k, a, b
arr = Range("a2:e" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
tm = [n3].Resize(6)
ReDim brr(1 To UBound(arr, 1) - 1, 1 To 4)
For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
If arr(j, 1) <> arr(j + 1, 1) Then
For k = i To j
For a = k To j
If arr(a, 3) <> arr(a + 1, 3) Then
For b = k To a
If InStr(arr(b, 1), "车间") > 0 Then '非车间即为科室
'----------------
'由于有单刷存在以下范围内代码的结果是不确定的
If CDate(arr(b, 4)) < #12:00:00 PM# Then
If arr(b, 3) = arr(b + 1, 3) Then
If arr(b, 4) > tm(3, 1) Then brr(b, 2) = "√"
brr(b, 1) = "上班"
Else
If arr(b, 4) < tm(6, 1) Then brr(b, 3) = "√"
brr(b, 1) = "下班"
End If
Else '条件不确定这里的代码我就不写了(指单刷)
End If
'----------------
Else '科室,结果应该没毛病
If CDate(arr(b, 4)) < #12:00:00 PM# Then
If arr(b, 4) > tm(1, 1) Then brr(b, 2) = "√"
brr(b, 1) = "上班"
Else
If arr(b, 4) < tm(2, 1) Then brr(b, 3) = "√"
brr(b, 1) = "下班"
End If
End If
If a - k = 0 Then brr(b, 4) = "单刷"
Next
k = a: Exit For
End If
Next a, k
i = j: Exit For
End If
Next j, i
[f2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub |
|