将整个年级学生，按班级分成若干个小组，每班各小组人数尽量平均

yh21cn

现在需要将整个年级学生，按班级分成若干个小组，每班各小组人数尽量平均，求助各位表哥~~~

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     With Worksheets("sheet1")
   
9.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.         arr = .Range("a2:b" & r)
    
11.         zs = .Range("g1")
    
12.         ReDim brr(1 To UBound(arr), 1 To zs * 2)
    
13.         For i = 1 To UBound(arr)
    
14.             If Not d.exists(arr(i, 2)) Then
    
15.                 Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
16.             End If
    
17.             d(arr(i, 2))(i) = Empty
    
18.         Next
    
19.         m = 1
    
20.         n = 1
    
21.         For Each aa In d.keys
    
22.             For Each bb In d(aa).keys
    
23.                 brr(m, n) = arr(bb, 1)
    
24.                 brr(m, n + 1) = arr(bb, 2)
    
25.                 n = n + 2
    
26.                 If n > UBound(brr, 2) Then
    
27.                     m = m + 1
    
28.                     n = 1
    
29.                 End If
    
30.             Next
    
31.         Next
    
32.         .Range("k3").Resize(m, UBound(brr, 2)) = brr
    
33.     End With
    
34. End Sub
    

复制代码

chxw68

详见附件。

yh21cn

chxw68 发表于 2023-4-3 11:08
详见附件。

谢谢大表哥

yh21cn

chxw68 发表于 2023-4-3 11:08
详见附件。

朋友，每个人的学生能不能随机分组？不按表格中的顺序

chxw68

修改好了。

yh21cn

chxw68 发表于 2023-4-3 11:36
修改好了。

好的，我测试一下，谢谢版主了

yh21cn

chxw68 发表于 2023-4-3 11:36
修改好了。

好用，非常感谢！