'好玩而已,不用字典来个,,,
Option Explicit
Sub test()
Dim arr, i, j, m, n, p, t
arr = [b3].CurrentRegion.Offset(1)
ReDim brr(1 To UBound(arr, 1), 1 To 100) As String
For i = 1 To UBound(arr, 1) - 2
For j = i + 1 To UBound(arr, 1) - 1
If arr(i, 1) > 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
m = 1: n = 1: p = 1
For i = 1 To UBound(arr, 1) - 1
m = m + 1: brr(m, n) = arr(i, 2)
If arr(i, 1) <> arr(i + 1, 1) Then
brr(1, n) = arr(p, 1): m = 1: n = n + 1: p = i + 1
End If
Next
[f1].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub |