vba 横向排名问题

Qs18

1. Sub qs()
   
2. Dim arr, brr, i
   
3. With Sheet1
   
4. r = .Cells(Rows.Count, 1).End(3).Row
   
5. arr = .Range("x5").Resize(r, 10)
   
6. brr = .Range("x5").Resize(r, 10)
   
7. ReDim crr(1 To r, 1 To 10)
   
8. For j = 1 To UBound(arr)
   
9.     For i = 1 To UBound(arr, 2)
   
10.         k = UBound(arr, 2) - 1
    
11.         For x = 1 To k
    
12.             If arr(j, x) < arr(j, x + 1) Then
    
13.                 t = arr(j, x)
    
14.                 arr(j, x) = arr(j, x + 1)
    
15.                 arr(j, x + 1) = t
    
16.                 k = k - 1
    
17.             End If
    
18.         Next
    
19.     Next
    
20. Next j
    
21. For j = 1 To UBound(arr)
    
22.    
    
23.     For x = 1 To UBound(brr, 2)
    
24.         For i = 1 To 3
    
25.             If arr(j, i) <> Empty Then
    
26.                 If arr(j, i) = brr(j, x) Then
    
27.                     crr(j, x) = i
    
28.                     arr(j, i) = -100
    
29.                     Exit For
    
30.                 End If
    
31.             End If
    
32.         Next
    
33.     Next
    
34. Next j
    
35. .Range("n5").Resize(r, 10).ClearContents
    
36. .Range("n5").Resize(r, 10) = crr
    
37. End With
    
38. End Sub
    

复制代码

Qs18

再试试看。。。。。。。。。

Qs18

再试试看。。。。。。。

ykcbf1100

横向排名，ArrayList法

ykcbf1100

横向排名。

1. Sub ykcbf()   '//2024.9.10
   
2.     Set List = CreateObject("System.Collections.ArrayList")
   
3.     r = Cells(Rows.Count, 1).End(3).Row
   
4.     For i = 5 To r
   
5.         List.Clear
   
6.         arr = Cells(i, "x").Resize(, 10)
   
7.         Cells(i, "n").Resize(, 10) = ""
   
8.         ReDim zrr(1 To 1, 1 To UBound(arr, 2))
   
9.         For j = 1 To UBound(arr, 2)
   
10.             If Not List.Contains(arr(1, j)) Then List.Add arr(1, j)
    
11.         Next
    
12.         List.Sort
    
13.         List.Reverse
    
14.         brr = List.toArray
    
15.         m = 0
    
16.         For x = 0 To UBound(brr)
    
17.             m = m + 1
    
18.             For j = 1 To UBound(arr, 2)
    
19.                 If arr(1, j) = brr(x) Then
    
20.                     zrr(1, j) = m
    
21.                     If m > 3 Then zrr(1, j) = ""
    
22.                     Exit For
    
23.                 End If
    
24.             Next
    
25.         Next
    
26.         Cells(i, "n").Resize(, 10) = zrr
    
27.     Next
    
28. End Sub
    

复制代码