悬赏-5元求个代码。。

oclassic123

qq 3445792008
附件里写的很清楚啦。

oclassic123

附件附件附件附件

maditate

好大的一只红包，可惜不见附件。

oclassic123

附件上了，怎么老上不去

oclassic123

maditate 发表于 2019-8-23 20:00
好大的一只红包，可惜不见附件。

来来来老哥

maditate

oclassic123 发表于 2019-8-23 20:08
来来来老哥

论坛抽疯中，暂时无法下载附件。

oclassic123

maditate 发表于 2019-8-23 20:12
论坛抽疯中，暂时无法下载附件。

q 3445792008 帮帮忙

qingc0221

-5元        

killq

qingc0221 发表于 2019-8-23 20:19
-5元

我去，看到你这回复我才明白过来：做完了还得请他喝小可乐。。。

一把小刀闯天下

'试了一下，第一行第一个数示例就是错的，应该为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