给特定不连续单元格排名

ewsky

有一运动会两短跑项目成绩，单元格不连续，怎样对其成绩分别排名？请大侠帮忙！（见附件）

microyip

把数据读出来，进行排序

ewsky

microyip 发表于 2017-9-20 13:16
把数据读出来，进行排序

求一个VBA代码！谢谢！

paciguard

做好了，试试，

1. Sub 按钮1_Click()
   
2. Dim a, b(), d, da
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set da = CreateObject("Scripting.Dictionary")
   
5. a = Range("G2:G" & [g65536].End(3).Row)
   
6. b = Range("H2:H" & [g65536].End(3).Row)
   
7. For i = 1 To UBound(a)
   
8. If Not d.exists(a(i, 1)) And Val(a(i, 1)) <> 0 Then d.Add a(i, 1), ""
   
9. Next i
   
10. Dim c&, ii&
    
11. c = d.Count
    
12. ii = 0
    
13. Do While c > 0
    
14. da.Add WorksheetFunction.Min(d.keys()), ii + 1
    
15. d.Remove WorksheetFunction.Min(d.keys())
    
16. ii = ii + 1
    
17. c = d.Count
    
18. Loop
    
19. For i = 1 To UBound(a)
    
20. If da.exists(a(i, 1)) Then b(i, 1) = da(a(i, 1))
    
21. Next i
    
22. Range("H2").Resize(UBound(b)) = b
    
23. End Sub
    

复制代码

ewsky

paciguard 发表于 2017-9-21 14:47
做好了，试试，

感谢你的代码！不过你只是按照一个项目进行了排名，没有区分另一个项目“男子甲组200m”,因此男子甲组200m没有正确的名次，这个项目也要排出1、2、3……名，应该怎么做呢？（其实我这里共有六个项目，而且每个项目的人数不固定），请帮忙，万分感谢！（我是初学者，代码最好有些注释）

uynayna

还有铅球，跳远，再加上合并单元格，数据错位，呵呵。帮你。

maditate

一个项目一张工作表。从上到下加序号。按选手成绩列排序，手工填充名次。再按按序号重摩托排序。这种问题根本就用不着VBA。体育老师没学过数学，没办法教你一下。

paciguard

改好了，试试：

1. Sub 按钮1_Click()
   
2. Dim a, b(), db, da, dd
   
3. Set da = CreateObject("Scripting.Dictionary")
   
4. Set db = CreateObject("Scripting.Dictionary")
   
5. Set dd = CreateObject("Scripting.Dictionary")
   
6. a = Range("F2:G" & [g65536].End(3).Row)
   
7. b = Range("H2:H" & [g65536].End(3).Row)
   
8. For i = 1 To UBound(a)
   
9. If Not da.exists(a(i, 1) & "," & a(i, 2)) And a(i, 2) <> "" Then da.Add a(i, 1) & "," & a(i, 2), ""
   
10. If Not db.exists(a(i, 1)) And a(i, 2) <> "" Then db.Add a(i, 1), ""
    
11. Next i
    
12. For j = 0 To UBound(db.keys())
    
13. Dim dc, c&, ii&
    
14. Set dc = CreateObject("Scripting.Dictionary")
    
15.     For Each keya In da
    
16.     If Split(keya, ",")(0) = db.keys()(j) Then
    
17.     If Not dc.exists(Split(keya, ",")(1)) And Val(Split(keya, ",")(1)) <> 0 Then dc.Add Val(Split(keya, ",")(1)), ""
    
18.     End If
    
19.     Next
    
20. c = dc.Count
    
21. ii = 0
    
22. Do While c > 0
    
23. dd.Add db.keys()(j) & "," & WorksheetFunction.Min(dc.keys()), ii + 1
    
24. dc.Remove WorksheetFunction.Min(dc.keys())
    
25. ii = ii + 1
    
26. c = dc.Count
    
27. Loop
    
28. Next j
    
29. 
    
30. For i = 1 To UBound(a)
    
31. If dd.exists(a(i, 1) & "," & a(i, 2)) Then b(i, 1) = dd(a(i, 1) & "," & a(i, 2))
    
32. Next i
    
33. 
    
34. Range("H2").Resize(UBound(b)) = b
    
35. 
    
36. End Sub
    

复制代码

ewsky

paciguard 发表于 2017-9-21 22:35
改好了，试试：

试过了，很好用，正是我需要的，非常感谢！
同时非常鄙视没学过数学的体育老师，手工操作一类的问题会在这里提问吗？真是无语。EXCELHOME，高手云集之地，今天在这里第一次享受了自己想要的，再次感谢！

ewsky

paciguard 发表于 2017-9-21 22:35
改好了，试试：

帮忙看看这个程序运行缓慢，要等三、四分钟 的样子。

1. Sub grf() '短跑预赛分组
   
2.    
   
3.     Application.ScreenUpdating = False '加在程序开始
   
4.     pds = Sheet2.[m1]        '跑道数
   
5.     With Sheet1
   
6.         arr = .Range("a1:f" & .[a65536].End(3).Row)
   
7.         org = arr
   
8.         Set d1 = CreateObject("scripting.dictionary")
   
9.         Set d2 = CreateObject("scripting.dictionary")
   
10.         
    
11.         For i = 2 To UBound(arr)       '参加各项目的人数，行号
    
12.             d1(arr(i, 4)) = d1(arr(i, 4)) & "," & i
    
13.         Next
    
14.    
    
15.         For Each xm In d1.keys      '对于每个项目
    
16.             xrr = Split(d1(xm), ",")       '各项目的行号
    
17.             rs = UBound(xrr)                                         '第1步：统计项目人数
    
18.             zs = Int((rs - 0.001) / pds) + 1                         ' 第2步：确定组次
    
19.             For k = 1 To UBound(xrr)                                 '第3步：对项目进行分组
    
20.                 i = xrr(k)
    
21.                 n = n + 1
    
22.                 If n > zs Then n = 1
    
23.                 arr(i, 5) = xm & n
    
24.                 arr(i, 6) = Rnd        '随机数辅助列，用于乱序
    
25.             Next
    
26.         Next
    
27.         .Range("a1:f" & .[a65536].End(3).Row) = arr
    
28.         .Range("a2:f" & .[a65536].End(3).Row).Sort key1:=.[e2], key2:=.[f2]      '第4步：在各组内对运动员进行顺机排序
    
29.         arr = .Range("a1:f" & .[a65536].End(3).Row)
    
30.         .Range("a1:f" & .[a65536].End(3).Row) = org     '恢复原序
    
31.         For i = 2 To UBound(arr)
    
32.             d2(arr(i, 5)) = d2(arr(i, 5)) & "," & i       '每组人所在行
    
33.         Next
    
34.     End With
    
35.         
    
36.     With Sheet2                                                                   '第5步：确定道次
    
37.         .[a2].Resize(10000, 8).Clear
    
38.         For Each zu In d2.keys       '对于每个组
    
39.             xrr = Split(d2(zu), ",")
    
40.             bzrs = UBound(xrr)      '本组人数
    
41.             ReDim brr(1 To pds, 1 To 6)
    
42.             qs = Int((pds - bzrs + 1) / 2) + 1     '起始跑道
    
43.             n = 0
    
44.             For k = 1 To pds
    
45.                 brr(k, 1) = Right(zu, 1)
    
46.                 brr(k, 2) = k
    
47.                 If k >= qs Then
    
48.                     n = n + 1
    
49.                     If n <= bzrs Then
    
50.                         i = xrr(n)
    
51.                         For j = 1 To 4: brr(k, j + 2) = arr(i, j): Next
    
52.                     End If
    
53.                 End If
    
54.             Next
    
55.              r = .[a65536].End(3).Row + 2
    
56.             .Cells(r, 1).Resize(pds, 6) = brr     '显示本项目安排结果
    
57.         Next
    
58. 
    
59.       rr = .[a65536].End(3).Row + 2     '加空行
    
60.       For i = rr To 3 Step -1
    
61.       If .Cells(i, 1) <> .Cells(i - 1, 1) Then .Rows(i).Insert
    
62.            
    
63.        Next
    
64.         r = .[a65536].End(3).Row '加表头
    
65.        For i = 4 To r
    
66.       If .Cells(i, 2) = "1" Then .Cells(i - 1, 1) = "组次": .Cells(i - 1, 2) = "道次": .Cells(i - 1, 3) = "号码": .Cells(i - 1, 4) = "姓名": .Cells(i - 1, 5) = "单位": .Cells(i - 1, 6) = "项目": .Cells(i - 1, 7) = "成绩": .Cells(i - 1, 8) = "备注"
    
67.        Next
    
68.         Dim a  '加标题
    
69.        a = Format(Date, "yyyy年")   '当前年月日
    
70.         r = .[a65536].End(3).Row
    
71.          For i = 3 To r Step pds + 3
    
72.          If .Cells(i, 1) = "组次" Then .Cells(i - 1, 1) = "双河初中" & a & "田径运动会" & .Cells(i + 2, 6) & "检录表":
    
73.             
    
74.         Range(Cells(i - 1, 1), Cells(i - 1, 8)).Select '合并单元格并居中
    
75.       
    
76.       With Selection
    
77.       .HorizontalAlignment = xlCenter
    
78.        .VerticalAlignment = xlCenter
    
79.        .WrapText = False
    
80.       .Orientation = 0
    
81.       .AddIndent = False
    
82.        .IndentLevel = 0
    
83.        .ShrinkToFit = False
    
84.        .ReadingOrder = xlContext
    
85.        .MergeCells = False
    
86.         End With
    
87.        Selection.Merge
    
88.            
    
89.         Next
    
90.     End With
    
91.    
    
92.    
    
93.     Application.ScreenUpdating = True '打开屏幕刷新
    
94.    
    
95. End Sub

复制代码