Option Explicit
Sub test()
Dim arr, brr, i, j, k, m, cnt, p
arr = Range("a1:e" & Cells(Rows.Count, "b").End(xlUp).Row + 1).Value
ReDim pos(1 To UBound(arr, 1), 1 To 3)
p = 1: brr = arr
For i = 2 To UBound(arr, 1) - 1
If Len(arr(i + 1, 4)) > 0 Or i = UBound(arr, 1) - 1 Then
cnt = cnt + 1
pos(cnt, 1) = p + 1: pos(cnt, 2) = i: pos(cnt, 3) = arr(p + 1, 4)
p = i
End If
Next
Call bsort(pos, 1, cnt, 1, UBound(pos, 2), 3)
For i = 1 To cnt
For j = pos(i, 1) To pos(i, 2)
m = m + 1
For k = 1 To UBound(arr, 2)
brr(m, k) = arr(j, k)
Next
Next
Next
Call doevent(False)
With [a2]
.Resize(UBound(arr, 1), UBound(arr, 2)).Clear
With .Resize(m, UBound(brr, 2))
.Value = brr
.Borders.LineStyle = xlContinuous
End With
End With
p = 1
j = Cells(Rows.Count, "b").End(xlUp).Row
For i = 2 To j
If Len(Cells(i + 1, "d")) > 0 Or i = j Then
Cells(p + 1, "a").Resize(i - p).Merge
Cells(p + 1, "d").Resize(i - p).Merge
Cells(p + 1, "e").Resize(i - p).Merge
p = i
End If
Next
Call doevent(True)
End Sub
Function doevent(flag As Boolean)
With Application
.DisplayAlerts = flag
.ScreenUpdating = flag
End With
End Function
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 |