怎么提取各科成绩第一名？

lizhipei78

lc16whj 发表于 2024-10-24 10:47
高手，VBA不会，函数可以修改，WPS没安装，能不能按我的要求帮忙修改一下代码？

38楼，你参考一下

lc16whj

lizhipei78 发表于 2024-10-24 12:02
38楼，你参考一下

谢谢，等回家测试一下

Qs18

1. Sub qs() '2024/10/24'前5名可以随数据改变
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion.Value
   
5. crr = Sheet1.Range("a2:m" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
   
6. For j = 4 To UBound(arr, 2)
   
7.     s = arr(1, j)
   
8.     dic(s) = Application.WorksheetFunction.Transpose(Application.Index(crr, 0, j))
   
9. Next
   
10. k = dic.keys
    
11. For Each k In dic.keys
    
12.     tp = ""
    
13.     x = dic(k)
    
14.     n = UBound(x) - 1
    
15.     For m = 1 To UBound(x) '排序名次
    
16.         For y = 1 To n
    
17.             If x(y) < x(y + 1) Then
    
18.                tp = x(y)
    
19.                 x(y) = x(y + 1)
    
20.                 x(y + 1) = tp
    
21.             End If
    
22.         Next
    
23.         n = n - 1
    
24.     Next
    
25.     dic(k) = x
    
26. Next
    
27. 
    
28. ReDim brr(1 To 20000, 1 To 5)
    
29. m = 0
    
30. For j = 4 To UBound(arr, 2)
    
31.     For i = 2 To UBound(arr)
    
32.         ma1 = dic(arr(1, j))
    
33.         For mc = 1 To 5 '前5名可以随数据改变
    
34.             mat = mat & "|" & ma1(mc)
    
35.         Next
    
36.         If InStr(mat, arr(i, j)) > 0 Then
    
37.         m = m + 1
    
38.         brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 3) = arr(i, 3)
    
39.         brr(m, 4) = arr(1, j): brr(m, 5) = arr(i, j)
    
40.         End If
    
41.     Next i
    
42. Next j
    
43. Sheet2.Range("a2").Resize(2000, 5) = Empty
    
44. Sheet2.Range("a2").Resize(m, 5) = brr
    
45. Set dic = Nothing
    
46. End Sub
    

复制代码

Qs18

前5名可以随数据改变

Qs18

前5名可以随数据改变

lc16whj

Qs18 发表于 2024-10-24 13:14
前5名可以随数据改变

高手，可以把代码中所有的5自定义其他超过5的数字吗？

咔咔乱坠

函数，参与一下

1. =REDUCE(提取各科第一名!J1:N1,成绩!D1:M1,LAMBDA(x,y,VSTACK(x,LET(a,OFFSET(y,1,,99),FILTER(IFNA(HSTACK(成绩!A2:C10,y,a),y),MAX(a)=a,"")))))

复制代码

wengjl

lc16whj 发表于 2024-10-24 10:47
高手，VBA不会，函数可以修改，WPS没安装，能不能按我的要求帮忙修改一下代码？

万老师，你把6楼的代码贴上即可得到结果（容易理解逻辑）

一招秒杀

leeson7502 发表于 2024-10-23 22:31
高射炮打蚊子，你真厉害。寸有所长，尺有所短，抛开合适的应用场景谈优缺点毫无意义。你回了这么多贴，可 ...

有句话 解决问题的方法往往存在于另一个层次上。 死守30多年 微软从未更新过的VBA，人家早就淘汰了，没有明说而已，有人的智力 只能用用这面向 Beginner 的东西， 其他啥也不会，学不来啊。

一招秒杀

leeson7502 发表于 2024-10-23 22:31
高射炮打蚊子，你真厉害。寸有所长，尺有所短，抛开合适的应用场景谈优缺点毫无意义。你回了这么多贴，可 ...

有句话，解决问题的方法往往在另外一个层面，
还有句话 所有困难的问题，答案都在另一个层次：
还有句话，解决问题的办法永远在问题之外：
如果你所有的知识储备只有30多年从未更新的VBA,
不知道 还有 JavaScript ,python,Power Query,Access 数据库等等，
那你的知识储备 可能 太过贫乏了。