|
发表于 2016-6-24 11:27
|
显示全部楼层
本楼为最佳答案
代码如下,结果会产生在N-P列- Sub XX()
- Dim arr, d, n&
- Set d = CreateObject("Scripting.Dictionary")
- With Sheet1
- n = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("A2:J" & n)
- For i = 1 To n - 1
- If Not d.Exists(arr(i, 7)) Then
- d.Add arr(i, 7), arr(i, 7)
- Set d(arr(i, 7)) = CreateObject("Scripting.Dictionary")
- End If
- If arr(i, 2) <= TimeValue("14:00:00") Then
- If d(arr(i, 7)).Exists("两点前") Then
- d(arr(i, 7))("两点前") = d(arr(i, 7))("两点前") + 1
- Else
- d(arr(i, 7))("两点前") = 1
- End If
- Else
- If d(arr(i, 7)).Exists("两点后") Then
- d(arr(i, 7))("两点后") = d(arr(i, 7))("两点后") + 1
- Else
- d(arr(i, 7)).Add "两点后", 1
- End If
- End If
- Next
- x = 1
- .Cells(x, 14) = "姓名"
- .Cells(x, 15) = "两点前"
- .Cells(x, 16) = "两点后"
- For Each k In d.keys
- x = x + 1
- .Cells(x, 14) = k
- .Cells(x, 15) = d(k)("两点前")
- .Cells(x, 16) = d(k)("两点后")
- Next
- End With
- End Sub
复制代码 |
|