Option Explicit
'
Sub abc()
Dim a, i, j, k, p, m, pos, cnt, r
a = Range("a2:r" & [k2].End(xlDown).Row + 1).Value
ReDim pos(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a) - 1
If Len(a(i + 1, 18)) Or i = UBound(a) - 1 Then
m = m + 1
pos(m, 1) = p + 1: pos(m, 2) = i: pos(m, 3) = a(p + 1, 18)
p = i
End If
Next
Call bsort(pos, 1, m, 1, 3, 3)
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To m
For j = pos(i, 1) To pos(i, 2)
cnt = cnt + 1
For k = 1 To UBound(a, 2)
b(cnt, k) = a(j, k)
Next
Next
Next
Application.ScreenUpdating = False
[t:ak].Clear
With [t2].Resize(UBound(b) - 1, UBound(b, 2))
.Borders.LineStyle = xlContinuous
.Value = b
End With
p = 1: r = [ad2].End(xlDown).Row
For i = 2 To r
If Len(Cells(i + 1, "ak").Value) Or i = r Then
Cells(p + 1, "ak").Resize(i - p).Merge
p = i
End If
Next
pos = Array(3, 5, 9, 10, 13, 14, 15, 16, 17)
p = 1
For i = 2 To r
If Len(Cells(i + 1, "ac").Value) Or i = r Then
For j = 0 To UBound(pos)
Cells(p + 1, 19 + pos(j)).Resize(i - p).Merge
Next
p = i
End If
Next
Application.ScreenUpdating = True
End Sub
'
Function bsort(a, 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 a(j, key) > a(j + 1, key) Then
For k = left To right
t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
Next
End If
Next
Next
End Function