Sub TEST()
Dim Arr, xD, i&, T1$, T2$, U&, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([B1], Cells(Rows.Count, 1).End(xlUp))
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 2): Arr(i, 2) = ""
If T1 = "" Then GoTo 101
If xD(T1 & "/") <> "" Then GoTo 101 '已是最高等級
U = xD(T1)
If U = 0 Then
N = N + 1: U = N: xD(T1) = N: Arr(N + 1, 1) = T1
End If
If T2 <> "" Then Arr(U + 1, 2) = T2
If Right(T2, 2) = "1." Then xD(T1 & "/") = "AAA" '記錄為最高等級
101: Next i
If N > 0 Then [D1:E1].Resize(N + 1) = Arr
End Sub
