Option Explicit
Sub test()
Dim arr, i, j, t, dic, m, n, cnt, p
arr = [a1].CurrentRegion.Offset(1)
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr, 1) - 1
If arr(i + 1, 1) = "公司" Then
ReDim brr(1 To i + 1, 1 To i + 1)
m = m + 1
For j = 1 To i
m = m + 1: dic(arr(j, 1)) = m
brr(m, 1) = arr(j, 1): brr(m, 2) = arr(j, 2)
brr(1, m) = arr(j, 1)
Next
cnt = i: m = 2: Exit For
End If
Next
Do
For i = m + 1 To UBound(arr, 1) - 1
If arr(i, 1) = "公司" Then p = i + 1
If arr(i, 1) = arr(m, 1) And arr(i, 2) = 1 Then Exit For
Next
If i = UBound(arr, 1) Then MsgBox "!!": Exit Do '数据有问题
For i = p To p + cnt - 2
For j = i + 1 To p + cnt - 1
If dic(arr(i, 1)) > dic(arr(j, 1)) Then
t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
End If
Next j, i
For i = p + m - 1 To p + cnt - 1
brr(i - p - m + n + 4, n + 3) = arr(i, 2)
Next
m = m + 1: n = n + 1
Loop Until m > cnt
[e1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub |