Sub test()
Dim r%, i%, ks%, j%, m%, n%
Dim arr, brr
Dim d As Object
Dim d1 As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("原始记录")
r = .Range("d65536").End(xlUp).Row
arr = .Range("d8:h" & r)
End With
For i = 1 To UBound(arr)
d(arr(i, 2) & arr(i, 3) & arr(i, 4)) = d(arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4)) + 1
Next
k = d.keys
ks = d.Count - 1
ReDim brr(1 To ks * 31, 1 To 13)
n = 0
For j = 0 To ks - 1
aa = k(j)
m = j * ks
For tim = 42917 To 42947
n = n + 1
brr(m + n, 2) = Mid(aa, 1, Application.Find("/", aa) - 1)
brr(m + n, 3) = Mid(aa, Application.Find("/", aa) + 1, Application.Find("/", aa, Application.Find("/", aa) + 1) - Application.Find("/", aa) - 1)
brr(m + n, 1) = Mid(aa, Application.Find("/", aa, Application.Find("/", aa) + 1) + 1, 5)
brr(m + n, 6) = Application.Text(tim, "yyyy-MM-dd")
Next
Next
For i = 1 To UBound(brr)
d1(brr(i, 2) & brr(i, 3) & brr(i, 1) & brr(i, 6)) = d1(brr(i, 2) & brr(i, 3) & brr(i, 1) & brr(i, 6)) + 1
Next
kkk = d1.keys
For Each dd In d1.keys
h = h + 1
n1 = 0
For i = 1 To UBound(arr)
If dd = arr(i, 2) & arr(i, 3) & arr(i, 4) & Application.Text(arr(i, 5), "yyyy-MM-dd") Then
n1 = n1 + 1
brr(h, n1 + 7) = Mid(Application.Text(arr(i, 5), "yyyy-MM-dd:hh:mm:ss"), 12, 8)
End If
Next
Next
Sheet2.Range("a3:l300").ClearContents
Sheet2.Range("a3").Resize(31, 13) = brr
End Sub |