如何用VBA进行体育考试分组

gwjkkkkk

hjd528 发表于 2024-4-14 18:26
谢谢！比较符合我的需求。我描述的不详细，应该是相同的选考号为一组，每组最多为20人，不同的选考号不能 ...

请参考。。。

ykcbf1100

hjd528 发表于 2024-4-14 18:30
谢谢！用函数进行分组确实有问题，我不小心弄错了。老师，一楼附件已更新，烦请再修改一下。

改好了。。。

ykcbf1100

代码已更新。。。

1. Sub ykcbf() '//2024.4.14
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("分组表")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         Set Rng = .[b3].Resize(r - 2, 5)
   
7.         With Rng
   
8.             .Parent.Sort.SortFields.Clear
   
9.             .Sort Key1:=.Item(4), Order1:=1, Key2:=.Item(5), Order2:=1, Header:=2
   
10.         End With
    
11.         st = Application.InputBox("请输入分组起始编号：", "分组编号", "101")
    
12.         If st = Empty Then Exit Sub
    
13.         arr = .[a1].Resize(r, 9)
    
14.         On Error Resume Next
    
15.         For i = 3 To UBound(arr)
    
16.             s = arr(i, 5) & arr(i, 6)
    
17.             If s <> Empty Then
    
18.                 d(s) = d(s) + 1
    
19.                 If Not d1.exists(s) Then
    
20.                     d1(s) = i
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.         For Each k In d.keys
    
25.             n = n + 1
    
26.             m = 0
    
27.             For i = 3 To UBound(arr)
    
28.                 s = arr(i, 5) & arr(i, 6)
    
29.                 If s = k Then
    
30.                     For x = 1 To d(s)
    
31.                         m = m + 1
    
32.                         x = m Mod 20
    
33.                         .Cells(d1(s) + m - 1, 7) = Val(st) + n - 1
    
34.                         .Cells(d1(s) + m - 1, 8) = IIf(x = 0, 20, x)
    
35.                         If m = d(s) Then Exit For
    
36.                     Next
    
37.                 End If
    
38.                 i = i + d(s) - 1
    
39.             Next
    
40.         Next
    
41.     End With
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

hjd528

ykcbf1100 发表于 2024-4-14 19:29
改好了。。。

还是有的问题，就是相同选考号的最多为20人一组，多的则另分一组，不同选考号不能编成一组。

hjd528

gwjkkkkk 发表于 2024-4-14 18:49
请参考。。。

谢谢！满足需求！

ykcbf1100

hjd528 发表于 2024-4-14 19:59
还是有的问题，就是相同选考号的最多为20人一组，多的则另分一组，不同选考号不能编成一组。

现在可以了，前面理解有误。

ykcbf1100

前面理解有误，现在应该没问题了。

1. Sub ykcbf() '//2024.4.14
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("分组表")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         Set Rng = .[b3].Resize(r - 2, 5)
   
7.         With Rng
   
8.             .Parent.Sort.SortFields.Clear
   
9.             .Sort Key1:=.Item(4), Order1:=1, Key2:=.Item(5), Order2:=1, Header:=2
   
10.         End With
    
11.         st = Application.InputBox("请输入分组起始编号：", "分组编号", "101")
    
12.         If st = Empty Then Exit Sub
    
13.         arr = .[a1].Resize(r, 9)
    
14.         On Error Resume Next
    
15.         For i = 3 To UBound(arr)
    
16.             s = arr(i, 5) & arr(i, 6)
    
17.             If s <> Empty Then
    
18.                 d(s) = d(s) + 1
    
19.                 If Not d1.exists(s) Then
    
20.                     d1(s) = i
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.         p = 20
    
25.         For Each k In d.keys
    
26.             r1 = d1(k): r2 = d1(k) + d(k) - 1
    
27.             For i = r1 To r2 Step p
    
28.                 n = n + 1
    
29.                 For x = 1 To p
    
30.                     rs = i + x - 1
    
31.                     .Cells(rs, 7) = Val(st) + n - 1
    
32.                     .Cells(rs, 8) = x
    
33.                     If rs = r2 Then Exit For
    
34.                 Next
    
35.             Next
    
36.         Next
    
37.     End With
    
38.     MsgBox "OK！"
    
39. End Sub
    

复制代码

hjd528

ykcbf1100 发表于 2024-4-14 20:02
现在可以了，前面理解有误。

谢谢老师，完美解决。

ykcbf1100

hjd528 发表于 2024-4-14 20:34
谢谢老师，完美解决。

终于解决。很多时候，就是对题意没理解透。

hjd528

gwjkkkkk 发表于 2024-4-14 18:49
请参考。。。

再麻烦老师一下，在最后一列增加带队教师，如何用VBA解决。

中考体育考试分组表-增加带队教师.rar (21.98 KB, 下载次数: 4)

2024-4-14 21:17 上传

点击文件名下载附件