帮助写代码，我想更省时些！

一指禅62

分组、场次代码

1. 
   
2. Private Function 分组模块(ByVal xCount As Integer) As Range
   
3.     Select Case xCount
   
4.         Case Is = 3: Set 分组模块 = Sheet1.Range("A1:BN7")
   
5.         Case Is = 4: Set 分组模块 = Sheet1.Range("A9:BN17")
   
6.         Case Is = 5: Set 分组模块 = Sheet1.Range("A19:BN29")
   
7.         Case Is = 6: Set 分组模块 = Sheet1.Range("A31:BN43")
   
8.     End Select
   
9. End Function
   
10. 
    
11. Private Function 对阵轮次规则(ByVal xCount As Integer)
    
12.     Select Case xCount
    
13.         Case Is = 3: 对阵轮次规则 = "23|13|12"
    
14.         Case Is = 4: 对阵轮次规则 = "14,23|13,42|12,34"
    
15.         Case Is = 5: 对阵轮次规则 = "25,34|15,23|14,53|13,42|12,45"
    
16.         Case Is = 6: 对阵轮次规则 = "16,25,34|15,64,23|14,53,62|13,42,56|12,36,45"
    
17.     End Select
    
18. End Function
    
19. 
    
20. Sub 生成比赛场次()
    
21.     Dim Sh As Worksheet, Sht As Worksheet, R%
    
22.     Set Sh = Sheets("运动员")
    
23.     Set Sht = Sheets("竞赛分组")
    
24.     R = Sh.Range("A65536").End(3).Row
    
25.     If R < 4 Then MsgBox "运动员表没有报名数据！": Exit Sub
    
26.     If MsgBox("执行本操作将导致现有数据丢失，请谨慎操作！" & vbCrLf & _
    
27.         "选择“是”生成比赛场次，以及竞赛分组；" & vbCrLf & _
    
28.         "选择“否”退出当前操作。", vbQuestion + vbYesNo, "重要提示") = vbNo Then
    
29.         Exit Sub
    
30.     End If
    
31.     Application.DisplayAlerts = False
    
32.     Application.ScreenUpdating = False
    
33.    
    
34.     Rem  数据整理（排序）
    
35.     Sh.Sort.SortFields.Clear
    
36.     Sh.Sort.SortFields.Add Range("D4:D" & R), 0, 1, 0, 0
    
37.     Sh.Sort.SortFields.Add Range("E4:E" & R), 0, 1, 0, 0
    
38.     With Sh.Sort
    
39.         .SetRange Range("A3:F" & R)
    
40.         .Header = xlYes
    
41.         .MatchCase = False
    
42.         .Orientation = xlTopToBottom
    
43.         .SortMethod = xlPinYin
    
44.         .Apply
    
45.     End With
    
46.    
    
47.     Rem  获取分组信息
    
48.     Dim arr, i%, j%, d As Object
    
49.     arr = Sh.Range("A4:F" & R)
    
50.     Set d = CreateObject("scripting.dictionary")
    
51.     For i = 1 To UBound(arr)
    
52.         If Not d.Exists(arr(i, 4)) Then
    
53.             d(arr(i, 4)) = arr(i, 1)
    
54.         Else
    
55.             d.Item(arr(i, 4)) = d.Item(arr(i, 4)) & "|" & arr(i, 1)
    
56.         End If
    
57.     Next
    
58.    
    
59.     Rem  编排比赛场次
    
60.     Dim 项目$, k, ydy, t1, t2, t3, m%, n%
    
61.     Dim a(), p%    '【比赛场次】数据
    
62.     Dim Rng As Range, setRng As Range
    
63.     项目 = Sh.Range("B2").Text
    
64.     Sht.Unprotect Password:="123"
    
65.     With Sht.Range("A1:BQ2000")
    
66.         .UnMerge
    
67.         .Borders.LineStyle = xlNone
    
68.         .Borders(xlDiagonalDown).LineStyle = xlNone
    
69.         .ClearContents
    
70.     End With
    
71.     Set setRng = Sht.Range("A1")
    
72.    
    
73.     For Each k In d.keys '遍历分组
    
74.         j = 0
    
75.         m = 0: n = 0
    
76.         ydy = Split(d.Item(k), "|")
    
77.         
    
78.         t1 = 对阵轮次规则(UBound(ydy) + 1)
    
79.         Set Rng = 分组模块(UBound(ydy) + 1)
    
80.         Rem 复制粘贴相应模块
    
81.         Rng.Copy
    
82.         With setRng
    
83.             .PasteSpecial
    
84.             .Value = 项目 & k
    
85.             For j = 0 To UBound(ydy)
    
86.                 .Offset(j * 2 + 1, 0).Offset(0, 1) = ydy(j)
    
87.             Next
    
88.         End With
    
89.         
    
90.         Rem  生成当前组的比赛轮次
    
91.         For Each t2 In Split(t1, "|") '遍历轮次
    
92.             m = m + 1
    
93.             For Each t3 In Split(t2, ",") '遍历场次
    
94.                 n = n + 1: p = p + 1
    
95.                 Rem 【比赛场次】数据
    
96.                 ReDim Preserve a(1 To 6, 1 To p)
    
97.                 a(1, p) = 项目 & k          '项目与分组
    
98.                 a(2, p) = "第" & m & "轮"   '轮次
    
99.                 a(3, p) = n                 '场序
    
100.                 a(4, p) = ydy(Mid(t3, 1, 1) - 1) '甲方
     
101.                 a(5, p) = ydy(Mid(t3, 2, 1) - 1) '乙方
     
102.             Next
     
103.         Next
     
104.         Set setRng = setRng.Offset(Rng.Rows.Count + 1, 0)   '下次粘贴位置
     
105.     Next
     
106.    
     
107.     Rem 输出到【比赛场次】
     
108.     With Sheets("比赛场次")
     
109.         .Unprotect Password:="123"
     
110.         .Range("A2:E1000").ClearContents
     
111.         .Range("A2").Resize(p, 6) = WorksheetFunction.Transpose(a)
     
112.         .Protect Password:="123"
     
113.     End With
     
114.     Application.ScreenUpdating = True
     
115.     Application.DisplayAlerts = True
     
116.     Sht.Protect Password:="123"
     
117.     Set d = Nothing
     
118.     Set Sh = Nothing
     
119.     Set Sht = Nothing
     
120.     MsgBox "OK"
     
121. End Sub
     
122. 
     

复制代码

一指禅62

成绩统计代码

1. Public Sub 导入比赛成绩()
   
2.     Dim Sh As Worksheet, R%
   
3.     Dim arr, i%, x%, key$, d As Object
   
4.     Set Sh = Sheets("竞赛分组")
   
5.     R = Sh.Range("BN65536").End(3).Row
   
6.     If R = 0 Then MsgBox "没有比赛数据！": Exit Sub
   
7.    
   
8.     Rem 收集比赛成绩
   
9.     arr = Sh.Range("A1:BN" & R)
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     For i = 1 To R
    
12.         If Sh.Cells(i, "BN") = "名次" Then
    
13.             key = Sh.Cells(i, "A")
    
14.         Else
    
15.             x = Val(Sh.Cells(i, "BN"))
    
16.             If x > 0 Then
    
17.                 d(Sh.Cells(i, "B").Value) = key & "第" & Mid("一二三四五六", x, 1) & "名"
    
18.             End If
    
19.         End If
    
20.     Next
    
21.    
    
22.     Rem  输出成绩
    
23.     With Sheets("运动员")
    
24.         R = .Range("A65536").End(3).Row
    
25.         For i = 4 To R
    
26.             If d.Exists(.Cells(i, 1).Value) Then
    
27.                 .Cells(i, "F").Value = d.Item(.Cells(i, 1).Value)
    
28.             Else
    
29.                 .Cells(i, "F").Value = "无比赛记录"
    
30.             End If
    
31.         Next
    
32.     End With
    
33.     Set d = Nothing
    
34.     Set Sh = Nothing
    
35. End Sub

复制代码

一指禅62

说明：
1、分组模版中的函数、公式全部保留，如有错误请自行修改（已检出错误）；
2、撤销工作表保护密码：123
3、揣摩楼主附件及要求而作，仅供楼主参考。
4、因疫情关在家里闷得慌，聊作消遣。若不符合竞赛规则，不接受讨论。

体育比赛分组与统计.zip (454.75 KB, 下载次数: 19)

2020-2-8 09:20 上传

点击文件名下载附件

金育高中李卫东

一指禅62 发表于 2020-2-7 19:26
成绩统计代码

你太高了！

一指禅62

金育高中李卫东 发表于 2020-2-8 09:36
你太高了！

附件审核中。