又到了开学季，听说今年本区学校新生入学搞阳光分班。所谓阳光分班，其实就是带一定随机性地分班。其实简单地用excel自带的VBA功能也能实现。今天我们就来简单实现一个随机分班的功能。
虽然说随机，其实还是得限定一些条件，比如男女人数，年龄等等，尽量使分出来的学生情况均衡一些。因此我们将要求有一些固定的数据，由于基于excel，简单地规定所有待分班的学生信息存放在第一个工作表，工作表名称不限，数据表格式如图：
接下来，我们将基于表中的数据进行处理。由于笔记本上安装的是WPS，下面的vba操作都将在wps上完成并测试通过。
点击WPS的“工具”，打开wps的开发工具菜单（常用的wps是不带有宏功能的，如果需要支持可以官方开通或网上查找下载安装宏模块）。
点击打开“vb编辑器”，如图所示：
选择“thisWorkbook”对象，并在右边空白区域开始编程操作。首先创建一个过程，所谓过程，就是vba中可以被当作宏执行的一段代码集合。
'创建名为classgrouping的过程，此过程将作为宏名称被识别执行
Sub ClassGrouping()
On Error Resume Next
'定义总行数等一些待用的变量
Dim TotalLines, i, j As Integer
Dim newSheet As Worksheet
Dim classSheet(20) As Worksheet '暂时只支持最多分20个班
Dim csInsertIndex(20) As Integer
Dim classTotal As Integer
classTotal = 2 '默认分成2个班，如果需要分成3个或4个班等，修改此处的值
TotalLines = ThisWorkbook.Sheets(1).Range("A65535").End(xlUp).Row '获取学生数据总数
End Sub接下来继续补充。这里分班的思路是分将所有人按男女分成两类，再每类里按年龄（从数据表“身份证号”列中获取）从大小到排列，再按顺序从上到下选择与班级数量相同的人数随机分，以此类推下去直到分完为止。对应到Excel操作上，就是一个排序。（为了加强随机性，在排序前先生成随机数列并按随机数排序一次。）
操作过程如下：
（1）创建一个新工作表，并命名为“分班情况”。如果存在此表则直接使用。将第一个工作表（学生数据表）原样复制到“分班情况”表。
（2）创建与班级数量相同的班级表，用于存放分出来的本班学生。
（3）循环新表中的学生数据，并根据“性别”列和“身份证号”列生成一个新的数值列（即：根据男或女分别用8和9代替，再和从身份证号中取出的出生年月拼合成一个7位数）并排序。
（4）根据班级数量，从上到下按顺序随机将学生分到不同的班级。
实现完整代码如下：
Sub ClassGrouping()
On Error Resume Next
'定义总行数等一些待用的变量
Dim TotalLines, i, j As Integer
Dim newSheet As Worksheet
Dim classSheet(20) As Worksheet '暂时只支持最多分20个班
Dim csInsertIndex(20) As Integer
Dim classTotal As Integer
classTotal = 2 '默认分成2个班，如果需要分成3个或4个班等，修改此处的值
TotalLines = ThisWorkbook.Sheets(1).Range("A65535").End(xlUp).Row '获取学生数据总数
If IsSheetExists("分班情况") Then
Set newSheet = ThisWorkbook.Sheets("分班情况")
Else
Set newSheet = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
newSheet.Name = "分班情况"
End If
newSheet.Range("A:N").Borders.LineStyle = xlNone
newSheet.Range("a2:N65536").Clear
ThisWorkbook.Sheets(1).Range("a1:d" & TotalLines).Copy '复制学生数据到“分班情况”表以待处理
newSheet.Range("a1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
newSheet.Range("a1").PasteSpecial Paste:=xlPasteFormats
newSheet.Range("a1").PasteSpecial Paste:=xlPasteColumnWidths
For i = 2 To TotalLines
newSheet.Range("e" & i) = Int(IIf(newSheet.Range("c" & i) = "男", "8", "9") & Mid(newSheet.Range("d" & i), IIf(18 = Len(newSheet.Range("d" & i)), 7, 8), 6)) '根据男女和出生年月生成新的数值，方便排序
newSheet.Range("G" & i) = Rnd(1) '生成随机数列，用于先行排序
Next i
newSheet.Range("b2:G" & TotalLines).Sort Key1:=newSheet.Range("G1"), order1:=xlDescending, Header:=xlNo
newSheet.Range("E1") = "班级"
newSheet.Range("F1") = "出生年月"
'将学生信息重新随机排序后再处理
newSheet.Range("b1:F" & TotalLines).Sort Key1:=newSheet.Range("e1"), order1:=xlAscending, Header:=xlYes
Dim rng As Range
Set rng = newSheet.Range("a1:F" & TotalLines)
rng.Borders.LineStyle = xlContinuous
'首先创建各班分表
For i = 1 To 20
If classTotal >= i Then
If IsSheetExists(i & "班") Then
'ThisWorkbook.Sheets(i & "班").Delete
Set classSheet(i) = ThisWorkbook.Sheets(i & "班")
Else
Set classSheet(i) = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
classSheet(i).Name = i & "班"
End If
ThisWorkbook.Sheets(1).Range("a1:e2").Copy
classSheet(i).Range("a1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
classSheet(i).Range("a1").PasteSpecial Paste:=xlPasteFormats
classSheet(i).Range("a1").PasteSpecial Paste:=xlPasteColumnWidths
classSheet(i).Range("e1") = "班级"
classSheet(i).Range("A:N").Borders.LineStyle = xlNone
classSheet(i).Range("a2:N65536").Clear
classSheet(i).Range("A1:E1").Borders.LineStyle = xlContinuous
csInsertIndex(i) = 1
ElseIf IsSheetExists(i & "班") Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets(i & "班").Delete
Application.DisplayAlerts = True
Else
End If
Next i
Dim index As Integer
index = 0
For i = 2 To TotalLines '开始处理
j = i - 2
'简单点，你一个我一个，随机确定谁先
If (j Mod classTotal) = 0 Then
vr = Split(RndNumberNoRepeat(classTotal), ",")
End If
index = j Mod classTotal
newSheet.Range("E" & i) = vr(index) & "班"
newSheet.Range("E" & i).Interior.ColorIndex = 34 + vr(index) '搞点颜色效果
'复制数据到分表
newSheet.Range("A" & i & ":E" & i).Copy
csInsertIndex(vr(index)) = csInsertIndex(vr(index)) + 1
classSheet(vr(index)).Range("A" & csInsertIndex(vr(index))).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
classSheet(vr(index)).Range("A" & csInsertIndex(vr(index))).PasteSpecial Paste:=xlPasteFormats
classSheet(vr(index)).Range("A" & csInsertIndex(vr(index))).PasteSpecial Paste:=xlPasteColumnWidths
j = j + 1
Next i
newSheet.Columns("G").Delete
newSheet.Columns("F").Delete
newSheet.Select
newSheet.Range("A1").Select
End Sub
'----------------------------------------------------------
' 以下是两个辅助的方法
'----------------------------------------------------------
'此方法用于判断指定的工作表是否存在
Function IsSheetExists(shtName As String)
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
If sht.Name = shtName Then
IsSheetExists = True
Exit Function
End If
Next
IsSheetExists = False
End Function
'此方法用于生成简单的随机数串
Function RndNumberNoRepeat(t As Integer)
Dim a(20) As Integer
Dim TempArray(20) As String
Dim iRa, i, j, ps As Integer
Dim ud(20) As Integer
For i = 0 To 20
a(i) = i
Next i
Randomize (Timer)
For i = 0 To t
iRa = Int(1 + (t - 1 + 1) * Rnd())
If ud(iRa) = 0 Then
ps = iRa
ud(iRa) = 1
Else
For j = 1 To t
If ud(j) <> 1 Then
ps = j
ud(j) = 1
Exit For
End If
Next j
End If
TempArray(i) = a(ps)
' Print b(i)
Next i
RndNumberNoRepeat = Join(TempArray, ",")
End Function代码编写完成并保存。接下来执行一下看看。首先在第一个工作表中按格式输入一些数据，点击“工具”->“运行宏”
如果点击“运行宏”失败，请修改“宏安全性”级别后并重新打开Excel。切记：一定要重新打开！
运行宏，将生成“分班情况”表和“1班”和“2班”两个表（本例中默认分成2个班）。
代码比较多，没有作过多的解释。如果有不懂可以留言，会第一时间予以说明。如果有更好的思路和建议，欢迎留言指教，谢谢。