VBA 古怪及特殊的排名?

On_fire

VBA 古怪及特殊的排名?

Sheet1是源数据,

需要对” 数值 “进行古怪及特殊的排名?

*

代码的逻辑如下,

要求当同值时, 取最后位值的排名

( 最大或最后的排名是所有值的总个数 )

*  

Sheet1(2)是升序的模拟结果

Sheet1(3)是降序的模拟结果  

*

希望能把代码做成一个函数, 以便可经常调用!

*

有难度,

希望有大神, 老师能出手帮忙, …谢谢!

蓝桥玄霜

排序的例子：

yjh_27

参见附件。

titi012

参与一下。。。

1. Function RankTT(Rng As Range, xRng As Range, iNum As Byte) As Long
   
2. 
   
3. Dim Arr, x&, y&, N, M&
   
4. Arr = Rng.Value
   
5. If iNum = 0 Then
   
6.     For y = 1 To UBound(Arr) - 1
   
7.     For x = 1 To UBound(Arr) - y
   
8.         If Arr(x, 1) > Arr(x + 1, 1) Then
   
9.             N = Arr(x, 1)
   
10.             Arr(x, 1) = Arr(x + 1, 1)
    
11.             Arr(x + 1, 1) = N
    
12.         End If
    
13.     Next x, y
    
14. Else
    
15.     For y = 1 To UBound(Arr) - 1
    
16.     For x = 1 To UBound(Arr) - y
    
17.         If Arr(x, 1) < Arr(x + 1, 1) Then
    
18.             N = Arr(x, 1)
    
19.             Arr(x, 1) = Arr(x + 1, 1)
    
20.             Arr(x + 1, 1) = N
    
21.         End If
    
22.     Next x, y
    
23. End If
    
24. 
    
25. For x = 1 To UBound(Arr)
    
26.     If Arr(x, 1) = xRng.Value Then
    
27.         For y = x To UBound(Arr)
    
28.             If Arr(y, 1) = Arr(x, 1) Then
    
29.                 M = y
    
30.             Else
    
31.                 Exit For
    
32.             End If
    
33.         Next y
    
34.     End If
    
35. Next x
    
36. 
    
37. RankTT = M
    
38. 
    
39. End Function

复制代码

1. 
   

复制代码

cidanji

vba不讨喜是数组方法缺失，排序得靠自备自定义函数 或调用其他语言 或现写排序过程

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
    [a1].CurrentRegion.Sort Key1:=Range("b1"), Order1:=xlAscending, Header:=xlGuess
    x = 0
    arr = [a1].CurrentRegion
    For j = 2 To UBound(arr)
        x = x + 1
        w = j
        For i = j + 1 To UBound(arr)
            If arr(j, 2) = arr(i, 2) Then
                x = x + 1
                w = i
            Else

                w = i - 1
                Exit For
            End If
        Next i
        For i = j To w
            arr(i, 3) = x
        Next i
        j = w
    Next j
    [a1].CurrentRegion = arr

End Sub
Sub 按钮2_Click()
    Application.ScreenUpdating = False
    [a1].CurrentRegion.Sort Key1:=Range("b1"), Order1:=xlDescending, Header:=xlGuess
    x = 0
    arr = [a1].CurrentRegion
    For j = 2 To UBound(arr)
        x = x + 1
        w = j
        For i = j + 1 To UBound(arr)
            If arr(j, 2) = arr(i, 2) Then
                x = x + 1
                w = i
            Else
                w = i - 1
                Exit For
            End If
        Next i
        For i = j To w
            arr(i, 3) = x
        Next i
        j = w
    Next j
    [a1].CurrentRegion = arr
End Sub

liulang0808

副本special rank.zip (21.58 KB, 下载次数: 5)

2024-1-5 19:57 上传

点击文件名下载附件

模拟供参考

lhj323323

liulang0808 发表于 2024-1-5 19:56
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    [a1].CurrentRegion.Sort Key1:=Range(" ...

好难！！！

ykcbf1100

cidanji 发表于 2024-1-5 18:51
vba不讨喜是数组方法缺失，排序得靠自备自定义函数 或调用其他语言 或现写排序过程

ArrayList方法可以实行数组排序的，只是系统版本要高一点。

cidanji

ykcbf1100 发表于 2024-1-5 21:08
ArrayList方法可以实行数组排序的，只是系统版本要高一点。

对，多数都可以，除了很老的版本