设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 窗体操作，根据排名提取组别
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2501|回复: 9

[已解决]窗体操作，根据排名提取组别

[复制链接]
发表于 2015-6-18 10:50 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 静若飞絮 于 2015-6-18 15:30 编辑

如题，窗体操作，输入分数随机，然后得出最终名次（含并列名次），如何提取出第一名和最后一名的组别。
最佳答案
月排行榜 / 总排行榜
grf1973
2015-6-19 10:28
考虑了两位小数及西式排名情况。
  1. Sub 排名()      '针对分数均为整数的情形
  2.     crr = Array("总排一", "总排二", "总排三", "总排四", "总排五", "总排六")
  3.     Dim arr(1 To 100000)
  4.     For i = 126 To 131     '以分数为下标，对应排名的textbox名称为值，相同分数则字符串累加
  5.         n = n + 1
  6.         If Me.Controls("Textbox" & i) <> "" Then
  7.             x = Val(Me.Controls("Textbox" & i)) * 100
  8.             arr(x) = arr(x) & "," & crr(n - 1)
  9.         End If
  10.     Next
  11.    
  12.     For i = UBound(arr) To 1 Step -1      '分数从大到小，排名从1到k
  13.         If Len(arr(i)) > 0 Then      '表示arr(i)有值
  14.             k = k + 1
  15.             xrr = Split(arr(i), ",")
  16.             xmin = ""
  17.             For j = 1 To UBound(xrr)
  18.                 p = p + 1
  19.                 Me.Controls(xrr(j)) = k
  20.                 xmin = xmin & Right(xrr(j), 1)
  21.                 If k = 1 Then xmax = xmax & Right(xrr(j), 1)
  22.             Next
  23.             k = p
  24.         End If
  25.     Next
  26.    
  27.     Me.TextBox124 = xmax
  28.     Me.TextBox125 = xmin
  29. End Sub
复制代码

分数统计.rar

24.14 KB, 下载次数: 6
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
grf1973
发表于 2015-6-18 15:03 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
用了辅助列。

分数统计.rar

30.32 KB, 下载次数: 7
回复

使用道具 举报

 楼主| 发表于 2015-6-18 16:15 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
grf1973 发表于 2015-6-18 15:03
用了辅助列。

嗯，这样可以，谢谢，有没不借助辅助列的方法，直接在窗体中提取出呢？
回复

使用道具 举报

grf1973
发表于 2015-6-19 09:32 | 显示全部楼层
可以，代码要长一些。
  1. Sub 排名()
  2.     crr = Array("总排一", "总排二", "总排三", "总排四", "总排五", "总排六")
  3.     Dim arr(1 To 6, 1 To 2)
  4.     For i = 126 To 131     '把得分和排名放到一个数组里
  5.         n = n + 1
  6.         arr(n, 1) = Me.Controls("Textbox" & i)
  7.         arr(n, 2) = crr(n - 1)
  8.     Next
  9.    
  10.     For i = 1 To 5      '对数组排序
  11.         For j = i + 1 To 6
  12.             x = arr(i, 1)
  13.             Y = arr(j, 1)
  14.             If Val(x) < Val(Y) Then
  15.                 tmp = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = tmp
  16.                 tmp = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = tmp
  17.             End If
  18.         Next
  19.     Next
  20.    
  21.     tmp = arr(1, 1): n = 1     '排名，考虑相同名次情况
  22.     For i = 1 To 6
  23.         x = arr(i, 1)
  24.         If Len(x) > 0 Then
  25.             If Val(x) < Val(tmp) Then n = n + 1
  26.             Me.Controls(arr(i, 2)) = n
  27.             tmp = arr(i, 1)
  28.         End If
  29.     Next
  30.    
  31.     For i = 1 To 6     '输出第1名和最后一名的组名
  32.         If Len(arr(i, 2)) > 0 Then
  33.             If Val(Me.Controls(arr(i, 2))) = n Then xmin = xmin & Right(arr(i, 2), 1)
  34.             If Val(Me.Controls(arr(i, 2))) = 1 Then xmax = xmax & Right(arr(i, 2), 1)
  35.         End If
  36.     Next
  37.     Me.TextBox124 = xmax
  38.     Me.TextBox125 = xmin
  39. End Sub
复制代码

分数统计.rar

31.6 KB, 下载次数: 5
回复

使用道具 举报

grf1973
发表于 2015-6-19 09:48 | 显示全部楼层
如果分数都为整数，代码可大大简化。可以试一下。
  1. Sub 排名()      '针对分数均为整数的情形
  2.     crr = Array("总排一", "总排二", "总排三", "总排四", "总排五", "总排六")
  3.     Dim arr(1 To 1000)
  4.     For i = 126 To 131     '以分数为下标，对应排名的textbox名称为值，相同分数则字符串累加
  5.         n = n + 1
  6.         If Me.Controls("Textbox" & i) <> "" Then
  7.             x = Val(Me.Controls("Textbox" & i))
  8.             arr(x) = arr(x) & "," & crr(n - 1)
  9.         End If
  10.     Next
  11.    
  12.     For i = 1000 To 1 Step -1      '分数从大到小，排名从1到k
  13.         If Len(arr(i)) > 0 Then      '表示arr(i)有值
  14.             k = k + 1
  15.             xrr = Split(arr(i), ",")
  16.             xmin = ""
  17.             For j = 1 To UBound(xrr)
  18.                 Me.Controls(xrr(j)) = k
  19.                 xmin = xmin & Right(xrr(j), 1)
  20.                 If k = 1 Then xmax = xmax & Right(xrr(j), 1)
  21.             Next
  22.         End If
  23.     Next
  24.    
  25.     Me.TextBox124 = xmax
  26.     Me.TextBox125 = xmin
  27. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-6-19 10:12 | 显示全部楼层
grf1973 发表于 2015-6-19 09:48
如果分数都为整数，代码可大大简化。可以试一下。

谢谢，不过分数会有1-2位小数，这个代码求出的排名结果是中式排名，假如说六组含并列，名次为1，1，2，3，4，5，还有种西式排名是1，1，3，4，5，6。
回复

使用道具 举报

grf1973
发表于 2015-6-19 10:23 | 显示全部楼层
如果最多只有两位小数，把分数*100化为整数后也可用5楼代码
回复

使用道具 举报

grf1973
发表于 2015-6-19 10:28 | 显示全部楼层    本楼为最佳答案   
考虑了两位小数及西式排名情况。
  1. Sub 排名()      '针对分数均为整数的情形
  2.     crr = Array("总排一", "总排二", "总排三", "总排四", "总排五", "总排六")
  3.     Dim arr(1 To 100000)
  4.     For i = 126 To 131     '以分数为下标，对应排名的textbox名称为值，相同分数则字符串累加
  5.         n = n + 1
  6.         If Me.Controls("Textbox" & i) <> "" Then
  7.             x = Val(Me.Controls("Textbox" & i)) * 100
  8.             arr(x) = arr(x) & "," & crr(n - 1)
  9.         End If
  10.     Next
  11.    
  12.     For i = UBound(arr) To 1 Step -1      '分数从大到小，排名从1到k
  13.         If Len(arr(i)) > 0 Then      '表示arr(i)有值
  14.             k = k + 1
  15.             xrr = Split(arr(i), ",")
  16.             xmin = ""
  17.             For j = 1 To UBound(xrr)
  18.                 p = p + 1
  19.                 Me.Controls(xrr(j)) = k
  20.                 xmin = xmin & Right(xrr(j), 1)
  21.                 If k = 1 Then xmax = xmax & Right(xrr(j), 1)
  22.             Next
  23.             k = p
  24.         End If
  25.     Next
  26.    
  27.     Me.TextBox124 = xmax
  28.     Me.TextBox125 = xmin
  29. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2015-6-19 10:28 | 显示全部楼层
请看附件。

分数统计.rar

33.07 KB, 下载次数: 5
回复

使用道具 举报

 楼主| 发表于 2015-6-19 10:53 | 显示全部楼层
grf1973 发表于 2015-6-19 10:28
请看附件。

嗯，是这个样子的{:1112:}，多谢！
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-26 06:24 , Processed in 0.349477 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表