'输出到当前工作表了,因为你后面的规则可能有问题,自己可以再拆分。源数据可以无序,,,
Option Explicit
Sub test()
Dim arr, i, j, k, p, pp, t, m, s
With Sheets("排课表")
arr = .Range("a1:e" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
ReDim brr(UBound(arr, 1) * 4, 1 To 4)
For i = 2 To UBound(arr, 1) - 1
t = Replace(Replace(arr(i, 3), ":", ":"), Space(1), vbNullString)
t = Split(arr(i, 3), "-")
arr(i, 5) = Format(Split(t(0), ":")(0), "00") & Format(Split(t(0), ":")(1), "00") & _
Format(Split(t(1), ":")(0), "00") & Format(Split(t(1), ":")(1), "00")
Next
p = 2
Call bsort(arr, 2, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
For i = 2 To UBound(arr, 1) - 1
If arr(i, 1) <> arr(i + 1, 1) Then
Call bsort(arr, p, i, 1, UBound(arr, 2), 2)
For j = p To i
If arr(j, 1) <> arr(j + 1, 1) Or arr(j, 2) <> arr(j + 1, 2) Then
Call bsort(arr, p, j, 1, UBound(arr, 2), 5)
For k = p To j
s = s & vbNewLine & arr(k, 4)
If arr(k, 1) <> arr(k + 1, 1) Or arr(k, 2) <> arr(k + 1, 2) Or arr(k, 5) <> arr(k + 1, 5) Then
m = m + 1
brr(m, 1) = arr(k, 1): brr(m, 2) = arr(k, 2): brr(m, 3) = arr(k, 3): brr(m, 4) = Mid(s, 2)
p = k + 1: s = vbNullString
End If
Next
p = j + 1
End If
Next
For j = 1 To UBound(brr, 2)
brr(pp, j) = arr(1, j)
Next
p = i + 1: m = m + 3: pp = m
End If
Next
.[h1].Resize(m + 1, UBound(brr, 2)) = brr
End With
End Sub
Function bsort(arr, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If arr(j, key) > arr(j + 1, key) Then
For k = left To right
t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
Next
End If
Next
Next
End Function |