楼主
kevinchengcw |
Q: 如何用VBA代码实现考场排序时不将同一班级学生排列在一起？
A: 本例利用一个提问帖演示一种排列及判断的方式，代码如下：
- Sub test()
- Dim M, N, I As Long
- Dim Dic, Arr
- Dim Same As Boolean
- Dim Str As String
- Application.ScreenUpdating = False '关闭屏幕刷新以提高处理速度
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目，本例中会利用字典项目的易于添加删除的特性将已排过的删除掉
- With Worksheets("sheet1") '在数据区内循环，并将各项添加到字典内
- For N = 5 To .Cells(.Rows.Count, 2).End(3).Row '循环区域为从第5行起到最后一行
- Str = .Cells(N, 4).Value & vbTab & .Cells(N, 2).Value & vbTab & .Cells(N, 3).Value '利用BCD三列的内容做为item项，为了方便比较班级，将D列的内容放在最前面
- Dic.Add CStr(.Cells(N, 1).Value), Str '利用序号作为key，组合好的字段为item添加字典项目
- Next N
- End With
- With Worksheets("sheet2") '利用sheet2进行数据处理
- Do While Dic.Count > 0 '循环直至字典项目为0，即处理完全部项目
- Arr = Dic.keys '将字典的keys赋值给数组
- Same = True '初始化变量same为真，用于判断字典中剩余项目是否都是同一个班级，如果是则same继续为真值，否则为假
- For N = LBound(Arr) To UBound(Arr) '循环数组来提取对应的字典项，提取班级并进行比较
- If Split(Dic(Arr(0)), vbTab)(0) <> Split(Dic(Arr(N)), vbTab)(0) Then '如果有不相同的班级存在，则
- Same = False '变量same值为假
- Exit For '退出循环
- End If
- Next N
- If Same = False Then '当变量same值为假时，即存在不相同的班级时
- For N = LBound(Arr) To UBound(Arr) '循环数组中各项
- If Dic.exists(Arr(N)) Then '如果存在对应的字典项则
- If Arr(N) = 1 Then '如果数组的值为1（即第一次执行，此时因sheet2中无初始数据，故要专门执行一次）
- .Cells(1, 1) = 1
- .Cells(1, 2) = Split(Dic(Arr(N)), vbTab)(1)
- .Cells(1, 3) = Split(Dic(Arr(N)), vbTab)(2)
- .Cells(1, 4) = Split(Dic(Arr(N)), vbTab)(0)
- Dic.Remove Arr(N) '执行过后删除对应的字典项
- Else '如果不是第一次执行，则
- If Split(Dic(Arr(N)), vbTab)(0) <> .Cells(.Cells(.Rows.Count, 1).End(3).Row, 4).Value Then '判断当前字典项的班级与已有的最后一个班级是否不同，如不同则将对应内容写到对应单元格中
- .Cells(.Cells(.Rows.Count, 1).End(3).Row + 1, 1) = .Cells(.Rows.Count, 1).End(3).Row + 1
- .Cells(.Cells(.Rows.Count, 1).End(3).Row, 2) = Split(Dic(Arr(N)), vbTab)(1)
- .Cells(.Cells(.Rows.Count, 1).End(3).Row, 3) = Split(Dic(Arr(N)), vbTab)(2)
- .Cells(.Cells(.Rows.Count, 1).End(3).Row, 4) = Split(Dic(Arr(N)), vbTab)(0)
- Dic.Remove Arr(N) '并删除当前字典项
- End If
- End If
- End If
- Next N
- Else '如果same值为真时，即现有字典项内内容全部为同一班级时，则
- For N = LBound(Arr) To UBound(Arr) '循环字典项
- For I = 2 To .Cells(.Rows.Count, 1).End(3).Row '循环数据区
- If .Cells(I - 1, 4) <> Split(Dic(Arr(N)), vbTab)(0) And .Cells(I, 4) <> Split(Dic(Arr(N)), vbTab)(0) Then '如果数据区当前行的与上一行的班级与字典当前项不同，则在当前行处插入一行，写入当前字典项内容到对应单元格中
- .Rows(I).Insert
- .Cells(I, 2) = Split(Dic(Arr(N)), vbTab)(1)
- .Cells(I, 3) = Split(Dic(Arr(N)), vbTab)(2)
- .Cells(I, 4) = Split(Dic(Arr(N)), vbTab)(0)
- Dic.Remove Arr(N) '并删除当前字典项
- Exit For '跳出循环，以便循环到下一个字典项
- End If
- If Dic.Count = 0 Then Exit For '如果字典项计数为0时跳出循环，以免出错
- Next I
- Next N
- End If
- Loop
- Worksheets("sheet1").[b5].Resize(.Cells(.Rows.Count, 2).End(3).Row, 3) = .[b1].Resize(.Cells(.Rows.Count, 2).End(3).Row, 3).Value '将已排好的内容写回sheet1的原数据区
- .Cells.Clear '清空sheet2中的全部内容
- End With
- Set Dic = Nothing '清空字典项目
- Application.ScreenUpdating = True '打开屏幕刷新
- End Sub
方法解释如下：
利用字典记录全部数据，逐个循环数据，当班级不相同时写入数据，相同时跳过，直至剩余数据全部为同一班级时，在已排序范围内循环，如果有两行班级不同，且与现有数据班级也不同的行时，则将现有数据插入到两个班级之间，如此直至数据全部排列完毕。
附示例文件。
 考试排序，前后不同班.rar
|
