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

hjd528

体育考试分组
1. 表格排序：先将性别（E列）进行升序排序，然后将选考号（F列）按升序排列；（VBA已实现）
2. 分组编号：20人为一组，多余的排到下一组，不足20人的也为一组。（函数公式已实现）
3. 组内排序：从1开始进行编号。（函数公式已实现）

现需求：
1. 用VBA一步完成分组：先表格排序，然后完成分组编号和组内序号；
2. 分组编号的起始号可以自由设定（在弹窗中输入）

各位大侠，帮忙解决一下。谢谢！



中考体育考试分组表.rar (23.32 KB, 下载次数: 15)

2024-4-14 18:17 上传

点击文件名下载附件

ykcbf1100

你的分组没看懂啊，怎么会是101,202,303,404,505呢？不是应该101,201,301,401,501吗？

gwjkkkkk

Option Explicit
Sub TEST3()
    Dim ar, i&, r&, iStart&
   
    Application.ScreenUpdating = False
    iStart = Application.InputBox("起始编号", Title:="提示", Default:=5, Type:=1)
    If iStart = 0 Then Exit Sub
    iStart = iStart - 1
   
    r = Cells(Rows.Count, "A").End(xlUp).Row
    With Range("A2:I" & r)
        .Parent.Sort.SortFields.Clear
        .Sort key1:=.Item(5), Order1:=xlAscending, key2:=.Item(6), Order2:=xlAscending, Header:=xlYes
        ar = .Value
        For i = 2 To UBound(ar)
            If (i - 1) Mod 20 = 1 Then iStart = iStart + 1
            ar(i, 7) = iStart
            ar(i, 8) = IIf((i - 1) Mod 20 = 0, 20, (i - 1) Mod 20)
        Next i
        .Value = ar
    End With

    Application.ScreenUpdating = True
End Sub

gwjkkkkk

请参考附件。。。

ykcbf1100

看后面楼层。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.4.14
   
2.     With Sheets("分组表")
   
3.         r = .Cells(Rows.Count, 1).End(3).Row
   
4.         Set Rng = .[b3].Resize(r - 2, 5)
   
5.         With Rng
   
6.             .Parent.Sort.SortFields.Clear
   
7.             .Sort Key1:=.Item(4), Order1:=1, Key2:=.Item(5), Order2:=1, Header:=2
   
8.         End With
   
9.         m = Application.InputBox("请输入分组起始编号：", "分组编号", "101")
   
10.         If m = Empty Then Exit Sub
    
11.         arr = .[a1].Resize(r, 9)
    
12.         k = 20
    
13.         On Error Resume Next
    
14.         For i = 3 To UBound(arr) Step k
    
15.             n = n + 1
    
16.             For x = 1 To k
    
17.                 r1 = i + x - 1
    
18.                 arr(r1, 7) = Val(Left(m, Len(m) - 2)) + n - 1 & "01"
    
19.                 arr(r1, 8) = x
    
20.                 If r1 = r Then Exit For
    
21.             Next
    
22.         Next
    
23.         .[a1].Resize(r, 9) = arr
    
24.     End With
    
25.     MsgBox "OK！"
    
26. End Sub
    
27. 
    

复制代码

hjd528

ykcbf1100 发表于 2024-4-14 16:46
你的分组没看懂啊，怎么会是101,202,303,404,505呢？不是应该101,201,301,401,501吗？

老师说得对，分组确实有问题，应该是101,102,103，....等这样编号。一楼附件已更新。

hjd528

gwjkkkkk 发表于 2024-4-14 17:03
请参考附件。。。

谢谢！比较符合我的需求。我描述的不详细，应该是相同的选考号为一组，每组最多为20人，不同的选考号不能编成一组。老师，一楼附件已更新。烦请修改一下。

hjd528

ykcbf1100 发表于 2024-4-14 17:10
附件供参考。。。

谢谢！用函数进行分组确实有问题，我不小心弄错了。老师，一楼附件已更新，烦请再修改一下。

gwjkkkkk

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

Option Explicit
Sub TEST3()
    Dim ar, br, i&, j&, r&, iStart&, dic As Object, vKey, strKey$
   
    Application.ScreenUpdating = False
    iStart = Application.InputBox("起始编号", Title:="提示", Default:=101, Type:=1)
    If iStart = 0 Then Exit Sub
    iStart = iStart - 1
   
    Set dic = CreateObject("Scripting.Dictionary")
    r = Cells(Rows.Count, "A").End(xlUp).Row
   
    With Range("A2:I" & r)
        .Parent.Sort.SortFields.Clear
        .Sort key1:=.Item(5), Order1:=xlAscending, key2:=.Item(6), Order2:=xlAscending, Header:=xlYes
        ar = .Value
        For i = 2 To UBound(ar)
            strKey = ar(i, 5) & ar(i, 6)
            dic(strKey) = dic(strKey) & " " & i
        Next i
        For Each vKey In dic.keys
            br = Split(dic(vKey))
            For j = 1 To UBound(br)
                If j Mod 20 = 1 Then iStart = iStart + 1
                ar(br(j), 7) = iStart
                ar(br(j), 8) = IIf(j Mod 20 = 0, 20, j Mod 20)
            Next j
        Next
        .Value = ar
    End With

    Application.ScreenUpdating = True
End Sub