阳光分班优化请求

ycl0856

请求：能不能写设置一个窗口或表格通过设置部分学生指定到哪个班级。

limonet

你是来分享，我是来取经的。

大灰狼1976

已修改发帖分类

ykcbf1100

limonet 发表于 2024-8-30 15:00
你是来分享，我是来取经的。

取到什么真经了？

limonet

ykcbf1100 发表于 2024-8-30 19:10
取到什么真经了？

九阴真经。

renkangjizhen

连分班标准都看不到，咋解决？

chxw68

1. Sub test2()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim bjrs() As Integer
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     Set d2 = CreateObject("Scripting.Dictionary")
   
8.     Application.ScreenUpdating = False
   
9.     Application.DisplayAlerts = False
   
10.     Randomize Timer
    
11.     With Worksheets("预分班信息")
    
12.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.         If r > 1 Then
    
14.             arr = .Range("a2:b" & r)
    
15.             For i = 1 To UBound(arr)
    
16.                 d2(arr(i, 1)) = arr(i, 2)
    
17.             Next
    
18.         End If
    
19.     End With
    
20.     With Worksheets("一年级分班花名册")
    
21.         .AutoFilterMode = False
    
22.         r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
23.         arr = .Range("a1:o" & r)
    
24.         bjsl = .Range("q2").Value
    
25.         ReDim bjrs(1 To bjsl)
    
26.         For i = 7 To UBound(arr)
    
27.             If d2.exists(arr(i, 2)) Then
    
28.                 bj = d2(arr(i, 2))
    
29.                 bjrs(bj) = bjrs(bj) + 1
    
30.                 If Not d.exists(bj) Then
    
31.                     Set d(bj) = .Range("a5:o6")
    
32.                 End If
    
33.                 Set d(bj) = Union(d(bj), .Cells(i, 1).Resize(1, 15))
    
34.             Else
    
35.                 If Not d1.exists(arr(i, 3)) Then
    
36.                     Set d1(arr(i, 3)) = CreateObject("Scripting.Dictionary")
    
37.                 End If
    
38.                 d1(arr(i, 3))(i) = Empty
    
39.             End If
    
40.         Next
    
41.         For Each aa In Array("男", "女")
    
42.             If d1.exists(aa) Then
    
43.                 kk = d1(aa).keys
    
44.                 For i = 0 To UBound(kk) - 1
    
45.                     n = Int(Rnd() * (UBound(kk) - i)) + i + 1
    
46.                     temp = kk(i)
    
47.                     kk(i) = kk(n)
    
48.                     kk(n) = temp
    
49.                 Next
    
50.                
    
51.                 For i = 0 To UBound(kk)
    
52.                     bj = 1
    
53.                     For k = 2 To UBound(bjrs)
    
54.                         If bjrs(k) < bjrs(bj) Then
    
55.                             bj = k
    
56.                         End If
    
57.                     Next
    
58.                     bjrs(bj) = bjrs(bj) + 1
    
59.                     If Not d.exists(bj) Then
    
60.                         Set d(bj) = .Range("a5:o6")
    
61.                     End If
    
62.                     Set d(bj) = Union(d(bj), .Cells(kk(i), 1).Resize(1, 15))
    
63.                 Next
    
64.             End If
    
65.         Next
    
66.     End With
    
67. 
    
68.     For q = 1 To bjsl
    
69.         If d.exists(q) Then
    
70.             shtname = q & "班"
    
71.             On Error Resume Next
    
72.             Worksheets(shtname).Delete
    
73.             On Error GoTo 0
    
74.             Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
75.             With ws
    
76.                 .Name = shtname
    
77.                 With .Range("a1")
    
78.                     .Value = "2024年秋季一年级" & q & "班花名册"
    
79.                     .Resize(1, 15).Merge
    
80.                     With .Font
    
81.                         .Name = "微软雅黑"
    
82.                         .Size = 20
    
83.                     End With
    
84.                 End With
    
85.                 d(q).Copy .Range("a3")
    
86.                 r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
87.                 arr = .Range("a5:c" & r)
    
88.                 xy = 0
    
89.                 xx = 0
    
90.                 For i = 1 To UBound(arr)
    
91.                     arr(i, 1) = i
    
92.                     If arr(i, 3) = "男" Then
    
93.                         xy = xy + 1
    
94.                     Else
    
95.                         xx = xx + 1
    
96.                     End If
    
97.                 Next
    
98.                 .Range("a5:c" & r) = arr
    
99.                 With .Range("a2")
    
100.                     .Resize(1, 15).Merge
     
101.                     .Value = Space(4) & "总人数：" & UBound(arr) & "人，其中男生：" & xy & "人，女生：" & xx & "人"
     
102.                     With .Font
     
103.                         .Name = "微软雅黑"
     
104.                         .Size = 12
     
105.                     End With
     
106.                 End With
     
107.                 With .UsedRange
     
108.                     .HorizontalAlignment = xlCenter
     
109.                     .VerticalAlignment = xlCenter
     
110.                 End With
     
111.                 .Rows(1).RowHeight = 30
     
112.                 .Rows(2).RowHeight = 18
     
113.                 .Rows(3).Resize(2).RowHeight = 30
     
114.                 .Rows(5).Resize(UBound(arr)).RowHeight = 18
     
115.             End With
     
116.         End If
     
117.     Next
     
118.     Application.ScreenUpdating = True
     
119. End Sub
     
120. 
     
121. 
     

复制代码

chxw68

根据楼主要求重新写了一段代码。

chxw68

下面代码纠正了8楼代码中存在的一个BUG，比如预分班只指定了3名学生，而且这3名学生都是女生并且都分在一班，在这种情况下就会导致每个班男女不均衡。

ycl0856

chxw68 发表于 2024-8-31 14:47
下面代码纠正了8楼代码中存在的一个BUG，比如预分班只指定了3名学生，而且这3名学生都是女生并且都分在一班 ...

老师，在WPS下运行不“宏”，求指教