'看不太懂凑了一个,,,
Option Explicit
Sub test()
Dim arr, i, j, t, m, key, dic(5)
For i = 1 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
arr = [a3].CurrentRegion.Resize(, 4)
For i = 2 To UBound(arr, 1)
If Not dic(1).exists(arr(i, 3) & arr(i, 4)) Then
dic(2)(arr(i, 2) & arr(i, 3)) = 1
dic(3)(arr(i, 2)) = 1
dic(4)(arr(i, 3)) = 1
End If
dic(1)(arr(i, 3) & arr(i, 4)) = 1
dic(5)(arr(i, 4)) = 1
Next
ReDim arr(1 To UBound(arr, 1), 1 To 5)
For i = 1 To UBound(dic)
m = 0
For Each key In dic(i).keys
m = m + 1: arr(m, i) = key
Next
Next
For i = 1 To m - 1
For j = i + 1 To m
If StrComp(arr(i, 5), arr(j, 5), vbTextCompare) = 1 Then
t = arr(i, 5): arr(i, 5) = arr(j, 5): arr(j, 5) = t
End If
Next
Next
[ad4].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub |