Option Explicit
Sub test()
Dim arr, i, n
[c:d].ClearContents
arr = [b3:e8].Value
For i = 1 To UBound(arr, 1)
arr(i, 4) = i
Next
Call bsort(arr, 1, UBound(arr, 1), 1, 4, 1)
n = (arr(UBound(arr, 1) / 2 + 1, 1) + arr(UBound(arr, 1) / 2, 1)) / 2
For i = 1 To UBound(arr, 1)
arr(i, 2) = Abs(arr(i, 1) - n)
Next
Call bsort(arr, 1, UBound(arr, 1), 1, 4, 2)
n = (arr(UBound(arr, 1) / 2 + 1, 2) + arr(UBound(arr, 1) / 2, 2)) / 2
For i = 1 To UBound(arr, 1)
arr(i, 3) = arr(i, 2) / n
Next
Call bsort(arr, 1, UBound(arr, 1), 1, 4, 4)
[b3].Resize(UBound(arr, 1), 3) = arr
End Sub
Function bsort(arr, 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 arr(j, key) > arr(j + 1, key) Then
For k = left To right
t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
Next
End If
Next
Next
End Function |