'试了一下,第一行第一个数示例就是错的,应该为14
'好玩而已,跟金币无关。仅处理了一张表格,,,
Option Explicit
Sub test()
Dim arr, i, j, m, n
arr = [a1].CurrentRegion.Offset(1)
ReDim brr(1 To (UBound(arr, 1) - 1) * 2, 1 To UBound(arr, 2))
ReDim crr(1 To UBound(arr, 2) - 2, 1 To 3)
For i = 1 To UBound(arr, 1) - 1
m = m + 2
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
If j > 2 Then
crr(j - 2, 1) = j - 2
crr(j - 2, 2) = arr(i, j)
End If
Next
Call bsort(crr, 1, UBound(crr, 1), 1, UBound(crr, 2), 2, False)
n = 1: crr(1, 3) = n
For j = 2 To UBound(crr, 1)
If crr(j, 2) < crr(j - 1, 2) Then n = n + 1
crr(j, 3) = n
Next
Call bsort(crr, 1, UBound(crr, 1), 1, UBound(crr, 2), 1, True)
For j = 1 To UBound(crr, 1)
brr(m - 1, j + 2) = crr(j, 3)
Next
Next
With [ab2]
.Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
.Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End With
End Sub
Function bsort(arr, first, last, left, right, key, order)
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
If arr(j, key) < arr(j + 1, key) Xor order 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
End If
Next
Next
End Function |