运用Excel VBA 实现高校新生分班

songe

分班的主要步骤如下:
( 1) 按照专业名称，把生源Excel 表划分成各个专业表，统计各专业学生数，并将每个专业学生信息表保存为一个工作簿文件。
( 2) 把各专业学生信息表按照性别划分成男、女生表。
( 3) 将每张男、女生表按照生源地和成绩降序排列。由于全国各地高考总分不同，按照生源地和成绩降序2 个关键字进行排序，使同省份学生成绩由高到低排列，保证每个平行班成绩均衡，学生的学习能力基本一致。
( 4) 对排好序的学生表增加序号，并以Z 形方式根据序号给每位学生分配班级信息。第一轮按照1 班到n 班顺序将学生分配到各班，第二轮从n 班到1 班顺序将学生分配到各班。
( 5) 将男、女生表按照班级信息，划分到各个班级，检查是否存在同名学生，按照姓名升序排序，并统计各班级学生数，以" 专业名称+ n 班+ 人数" 命名每张班级表。

专业分组代码

1. For rowData = 2 To shtData．Range( "A1" ) ．CurrentRegion．Rows．Count
   
2. sDept = shtData．Cells( rowData，"G" ) ．Value ＇设置分组依据
   
3. bln = False
   
4. For Each shtNew In Worksheets
   
5. If shtNew．Name = sDept Then
   
6. bln = True
   
7. Exit For
   
8. End If
   
9. Next
   
10. If bln = False Then
    
11. Set shtNew = Worksheets．Add( after: =Worksheets( Worksheets．Count) )
    
12. shtNew．Name = sDept
    
13. shtData．Range( "A1: J1" ) ．Copy shtNew．Range( "A1" )
    
14. End If
    
15. rowNew = shtNew．Range( "A1" ) ．CurrentRegion．Rows．Count + 1
    
16. Intersect( shtData．Rows( rowData) ，shtData．Range( "A: J" ) ) ．Copy shtNew．Cells( rowNew，1)
    
17. Next rowData

复制代码

排序与添加序号代码

1. fPath = wbkThis．Path ＆ " \分4 班专业表" ＇设置路径
   
2. fName = Dir( fPath ＆ " * ．xlsx" )
   
3. Do While fName ＜＞ " "
   
4. Set wbkOpen = Workbooks．Open( fPath ＆ fName)
   
5. Set shtData = wbkOpen．Worksheets( 2)
   
6. shtData．Range( "K1" ) ．Value = " sxh" ‘添加顺序号
   
7. shtData．Range( " L1" ) ．Value = " bj" ‘添加班级
   
8. shtData． Range ( " A1" ) ． Sort Key1: = shtData． Range ( " J1" ) ，Order1: = xlAscending，Key2: =
   
9. shtData．Range( " I1" ) ，Type: = xlSortValues，Order2: = xlDescending，Header: = xlYes
   
10. For rowData = 2 To shtData．Range( "A1" ) ．CurrentRegion．Rows．Count
    
11. shtData．Cells( rowData，"K" ) ．Value = rowData － 1
    
12. Next
    
13. Loop

复制代码

分班级号

1. For rowData = 2 To shtData．Range( "A1" ) ．CurrentRegion．Rows．Count
   
2. sxh = shtData．Cells( rowData，"K" ) ．Value
   
3. If ( ( sxh － 1) \ 4) Mod 2 = 0 Then‘\是整除
   
4. Select Case sxh Mod 4
   
5. Case 1
   
6. shtData．Cells( rowData，" L" ) ．Value = 1
   
7. Case 2
   
8. shtData．Cells( rowData，" L" ) ．Value = 2
   
9. Case 3
   
10. shtData．Cells( rowData，" L" ) ．Value = 3
    
11. Case 0
    
12. shtData．Cells( rowData，" L" ) ．Value = 4
    
13. End Select
    
14. Else
    
15. Select Case sxh Mod 4
    
16. Case 1
    
17. shtData．Cells( rowData，" L" ) ．Value = 4
    
18. Case 2
    
19. shtData．Cells( rowData，" L" ) ．Value = 3
    
20. Case 3
    
21. shtData．Cells( rowData，" L" ) ．Value = 2
    
22. Case 0
    
23. shtData．Cells( rowData，" L" ) ．Value = 1
    
24. End Select
    
25. End If
    
26. Next

复制代码

同名检查代码

1. For rowData = 2 To zhs － 1
   
2. sKey = shtData．Cells( rowData，" B" ) ．Value
   
3. Set Rng = Range ( Cells ( rowData + 1，" B" ) ，Cells ( zhs，" B" ) ) ． Find ( sKey，LookAt: =
   
4. xlWhole)
   
5. If Rng Is Nothing Then
   
6. Else
   
7. msgResult = MsgBox( shtData．Name ＆ " 的B" ＆ rowData ＆ " 单元格数据重复" ，vbYes，
   
8. " 同名同姓警告" )
   
9. End If
   
10. Next

复制代码

摘自文献：运用Excel VBA 实现高校新生分班