Option Explicit
Sub 根据指定列数据重排工作表()
Dim a, i, j, p, m
a = Range("a1:h" & Cells(Rows.Count, "d").End(xlUp).Row).Value
ReDim pos(1 To UBound(a), 1 To 3)
For i = 1 To UBound(a)
For j = i To UBound(a)
If a(i, 1) = "门店与自提点交接单" Then p = j: Exit For
Next
For j = p To UBound(a)
If a(j, 4) = "收货人签字" Then
m = m + 1
pos(m, 1) = p: pos(m, 2) = j: pos(m, 3) = a(p + 1, 8)
i = j + 1: Exit For
End If
Next
Next
Call bsort(pos, 1, m, 1, 3, 3)
Application.ScreenUpdating = False
[i1].Resize(UBound(a) * 2, UBound(a, 2)).Clear
p = 1
For i = 1 To m
Cells(pos(i, 1), "a").Resize(pos(i, 2) - pos(i, 1) + 1, UBound(a, 2)).Copy Cells(p, "i")
p = p + pos(i, 2) - pos(i, 1) + 2
Next
Columns("i:i").Resize(, UBound(a, 2)).AutoFit
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