测试了下浙江省教育考试院给的2018年模拟演练（志愿填报）文件，发现bug颇多，想自行修改下VBA代码，却发现VBA有项目密码，不想就此停手，故参考网上的相关资料将VBA源码提取出来，附于此处，方便有需要者自行改进代码逻辑，仅供学习研究使用，请勿用于商业用途，如有违反后果自负，版权及解释权归浙江省教育考试院所有。
为了避免不必要的麻烦，文件下载和密码问题请自行解决，本处仅提供源码。
文件来自:浙江省高校招生志愿填报系统(模拟)
‘工作表单元格的值发生改变，触发Worksheet_Change事件
‘ target为发生变化的单元格或区域
‘ Application.EnableEvents = False表示再此后发生单元格变化等事件时不会触发事件过程，避免“死循环”
‘ Application.EnableEvents = True 恢复正常事件过程
‘ 只有第1列中单元格发生变化时，才处理，其他情况Undo，即值不允许改变
‘ 第1列的值发生变化分两种情况：（只有值大于等于1才认为是合理的，超过目前已选数默认为等于已选序号最大值+1）
‘ 1、原来已选，值发生变化，选择序号进行调整，重新排序
‘ 2、原来“待选”，值发生变化，重新排序
‘ 处理排序问题由ReSort完成后
‘
Private Sub Worksheet_Change(ByVal target As Range)
Dim R As Long, C As Long, Key As Long
Application.EnableEvents = False
On Error Resume Next
If target.Column = 1 And target.Count = 1 Then ‘检测到第1列一个元素有操作
R = target.Row
C = target.Column
Key = Val(target.Value)
If R > 2 And R <= NumSelected + 2 Then
If Key >= 1 Then
ReSort R, C, Key
Else
Application.Undo
Cells(R, 1).Select
MsgBox "请输入一个不小于1的整数！", vbCritical, "序号错误提示信息"
End If
ElseIf R > NumSelected + 2 And R <= NumUnselected + NumSelected + 2 Then
If Key >= 1 Then
ReSort R, C, Key
Else
Application.Undo
Cells(R, 1).Select
MsgBox "请输入一个不小于1的整数！", vbCritical, "序号错误提示信息"
‘target.Value = "待选"
End If
Else
Application.Undo
End If
Else
Application.Undo
End If
Application.EnableEvents = True
End Sub
‘单元格焦点发生改变，一般是选择单元格操作
‘原来在这个单元格，再单击鼠标选择这个单元格，这种情况不触发事件
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Application.EnableEvents = False
On Error Resume Next
S = target.Address
If target.Address = target.EntireRow.Address And target.Rows.Count = 1 Then ‘判断选择一行的条件
R = target.Row
If R > 2 And R <= NumUnselected + NumSelected + 2 Then ‘判断是否在项目行范围内
If Cells(R, 1).Value = "待选" Then ‘只有第1列为“待选”或值>=1
Selectitem R
ElseIf Val(Cells(R, 1).Value) >= 1 Then
CancelLine R
End If
End If
ElseIf target.Address = target.EntireRow.Address And target.Rows.Count > 1 Then ‘判断选择多行的条件
‘连续多行处理target.Address
If InStr(1, S, ",") = 0 Then
n = InStr(1, S, ":")
R1 = Mid(S, 2, n - 2)
R2 = Right(S, Len(S) - n - 1)
If R1 > NumSelected + 2 And R2 <= NumUnselected + NumSelected + 2 Then
SelectMultiTtems R1, R2
ElseIf R1 > 2 And R2 <= NumSelected + 2 Then
CancelMultiLines R1, R2
End If
End If
ElseIf target.Address = "$L$1:$M$1" Then ‘自动保存导入文档处理
If NumSelected = 0 Then
MsgBox " 目前已选志愿项=0，不生成志愿文档！" + vbCrLf + vbCrLf, vbCritical, "自动生成志愿文档提示"
Else
Yes = MsgBox("系统将选中志愿项（前80项）保存到‘志愿导入表.xls’文档中" + vbCrLf + vbCrLf + vbTab + vbTab + "确定要继续吗？", vbQuestion + vbYesNo, "自动生成志愿文档提示")
If Yes = vbYes Then
SaveAsExcel
MsgBox " 志愿文档“志愿导入表.xls”已经成功生成！" + vbCrLf + vbCrLf + " 志愿文档保存在本工作簿文档所在文件夹中", vbInformation, "自动生成志愿文档提示"
End If
End If
Worksheets("Sheet1").Range("A2").Select
End If
Application.EnableEvents = True
End Sub
Private Sub Workbook_Open()
Dim Welcome As String
Range("A1").Select ‘打开窗体停留在A1单元格
Welcome = "欢迎进入志愿预选Excel操作文档！" + vbCrLf + vbCrLf
Welcome = Welcome + "1、请按照操作说明进行选择操作。" + vbCrLf
Welcome = Welcome + "2、单击【自动生成志愿文档】单元格，生成文档“志愿导入表.xls”。" + vbCrLf
Welcome = Welcome + "3、文档“志愿导入表.xls”保存在与当前操作文档相同的文件夹中。" + vbCrLf
Welcome = Welcome + "4、通过志愿填报系统将“志愿导入表.xls”导入到志愿填报系统网页。" + vbCrLf
MsgBox Welcome, vbInformation, "志愿预选文档欢迎信息"
VBAInitlize ‘初始化
End Sub
Public NumUnselected As Long, NumSelected As Long
Public NumColumn As Long
Public MaxItem As Integer
Sub VBAInitlize()
‘前两行冻结
MaxItem = 80 ‘普通批次最多填报80个志愿
ActiveWindow.SplitColumn = 0
ActiveWindow.SplitRow = 2
ActiveWindow.FreezePanes = True
Application.EnableEvents = False ‘事件失效：ReCount事件过程中有改变单元格值的语句，会引发Change事件。该语句用于屏蔽事件的发生
ReCount
Application.EnableEvents = True ‘事件可用
Range("A1").Select ‘打开窗体后焦点在A1单元格
End Sub
‘ 计算几个重要数据：已选数量、未选数量、有效列数
‘ 统计已选志愿个数NumSelected：3-30000行统计第1列大于等于1的个数
‘ 统计未选志愿个数NumUnselected：3-30000行统计第1列“待选”的个数
‘ 统计有效列数NumColumn：第2列中非空项
‘ 第1行第3列显示已选项数
‘ 第1行第6列显示总项数
Sub ReCount()
NumSelected = Application.WorksheetFunction.CountIf(Range("A3:A30000"), ">=1") ‘已选项数
NumUnselected = Application.WorksheetFunction.CountIf(Range("A3:A30000"), "待选") ‘未选项数
NumColumn = Application.WorksheetFunction.CountIf(Cells(3, 1).EntireRow, "<>") ‘有效列数
Cells(1, 3).Value = NumSelected ‘已选项数
Cells(1, 6).Value = NumUnselected + NumSelected ‘总项数
End Sub
‘重新排序的设计思想：
‘ 1、为新序号留出空间，即从新序号后的全部序号都加1，这样新序号就唯一了
‘ 2、按照序号重新排序，这是调用Excel内部过程完成后的
‘ 3、排序结束后，重新编号
‘ 重新排序分2种情况
‘ 1、在已选区域中输入有效序号(大于等于1)
‘ 2、在待选区域中输入有效序号(大于等于1)
‘ Key为输入的序号，R为行号，C为列号
Sub ReSort(ByVal R As Long, ByVal C As Long, Key As Long)
Dim S1 As String, S2 As String
S1 = Cells(R, 3).Value ‘待改变序号项目的院校名，用于弹出框信息提示
S2 = Cells(R, 5).Value ‘待改变序号项目的专业名，用于弹出框信息提示
For I = Key To NumSelected ‘改变序号：从Key开始到先前已选数，序号+1；如果Key大于已选数，该循环跳过，不执行
Cells(I + 2, 1).Value = I + 1 ‘这样就为新序号留出空间了
Next I
Cells(R, C).Value = Key ‘在上述改变序号过程中有可能被一起“改变”了
RA = "A" & R & ":" & Chr(NumColumn + 64) & R ‘准备改变格式
Range(RA).Font.Color = vbBlue
Range(RA).Interior.ThemeColor = xlThemeColorAccent4
Range(RA).Interior.TintAndShade = 0.599963377788629
AllRange = "A3:" & Chr(NumColumn + 64) & (NumSelected + NumUnselected + 102)
Range(AllRange).Sort key1:=Range("A3"), order1:=xlAscending ‘重新排序
If R > NumSelected + 2 Then ‘判断是否新选择的：如果是新选择的，选中数+1，未选数-1
NumSelected = NumSelected + 1
NumUnselected = NumUnselected - 1
End If
Cells(1, 3).Value = NumSelected
For I = 1 To NumSelected
Cells(I + 2, 1).Value = I ‘各序号刷新一遍
Next I
If Key > NumSelected Then Key = NumSelected
Cells(Key + 2, 1).EntireRow.Select ‘焦点保持在刚改变序号的行
MsgBox "你选择的志愿项排在预选志愿的第（" & Key & "）号：" + vbCrLf + vbCrLf + " “" & S1 + " - " + S2 & "”", vbOKOnly, "志愿选择提示信息"
End Sub
‘选中一行的处理：
‘ 1、原来是待选行，将“待选”改为最后一项预选值（NumSelected = NumSelected + 1），同时改变“目前已选志愿数”所在单元的值
‘ 2、将选中行数据区域的底纹与字体颜色作相应修改
‘ 3、按照预选志愿序号进行排序
‘ 4、最后焦点落在本行，只是位置、格式发生了改变
Sub Selectitem(ByVal R As Integer)
S1 = Cells(R, 3).Value
S2 = Cells(R, 5).Value
Yes = MsgBox("你确定要选择下列项目作为预选志愿项吗？" + vbCrLf + vbCrLf + " “" & S1 + " - " + S2 & "”", vbYesNo, "志愿选择提示信息")
If Yes = vbYes Then
NumSelected = NumSelected + 1 ‘已选值+1
NumUnselected = NumUnselected - 1 ‘未选值-1
Cells(1, 3).Value = NumSelected ‘“目前已选志愿数”单元格赋值
Cells(R, 1) = NumSelected ‘所选行赋最新序号
RA = "A" & R & ":" & Chr(NumColumn + 64) & R ‘以下改变格式
Range(RA).Font.Color = vbBlue
Range(RA).Interior.ThemeColor = xlThemeColorAccent4
Range(RA).Interior.TintAndShade = 0.599963377788629
AllRange = "A3:" & Chr(NumColumn + 64) & (NumSelected + NumUnselected + 102)
Range(AllRange).Sort key1:=Range("A3"), order1:=xlAscending ‘重新排序
Cells(NumSelected + 2, 1).EntireRow.Select
MsgBox "你选择的志愿项排在预选志愿的第（" & NumSelected & "）号：" + vbCrLf + vbCrLf + " “" & S1 + " - " + S2 & "”", vbOKOnly, "志愿选择提示信息"
End If
End Sub
‘选中多行的处理：
‘ 1、原来是待选区域，将“待选”改为最后一项预选值（NumSelected = NumSelected + 1），同时改变已选值所在单元的值
‘ 2、将选中行数据区域的底纹与字体颜色作相应修改
‘ 3、按照预选志愿序号进行排序
‘ 4、最后焦点落在已选区域，只是位置、格式发生了改变
‘ 5、多行选择可以是在“筛选”状态下进行的
Sub SelectMultiTtems(ByVal R1 As Integer, ByVal R2 As Integer)
Dim n As Long ‘选中志愿项目数
Dim m As Long, R As Long
Dim AllRange As String, Range1 As String, S As String
m = NumSelected + 1 ‘选中项起始序号
Range1 = "A" & R1 & ":A" & R2 ‘选中区域
n = Range(Range1).SpecialCells(xlCellTypeVisible).Count ‘计算行数n。没有用n=abs(R2-R1)+1计算是考虑了筛选情况下的选择问题
If n > 2 Then ‘行数不同，提示方式略有不同
‘超过2行
S = " " + Cells(R1, 3).Value + " - " + Cells(R1, 5).Value + vbCrLf
S = S + " ..............." + vbCrLf
S = S + " " + Cells(R2, 3).Value + " - " + Cells(R2, 5).Value
Else
‘2行
S = " " + Cells(R1, 3).Value + " - " + Cells(R1, 5).Value + vbCrLf
S = S + " " + Cells(R2, 3).Value + " - " + Cells(R2, 5).Value
End If
S1 = "你确定要选择下列" & n & "个（第" & R1 & " ... " & R2 & "行）项目作为预选志愿吗？"
Yes = MsgBox(S1 + vbCrLf + vbCrLf + S, vbYesNo, "志愿选择提示信息")
If Yes = vbYes Then
For R = R1 To R2
If Range("A" & R).EntireRow.Hidden = False Then ‘对筛选情况下的隐藏行不处理，下面是一行一行的处理过程
NumSelected = NumSelected + 1 ‘已选数+1
NumUnselected = NumUnselected - 1 ‘未选数-1
Cells(1, 3).Value = NumSelected ‘“目前已选志愿数”单元格赋值
Cells(R, 1) = NumSelected ‘所选行赋最新序号
RA = "A" & R & ":" & Chr(NumColumn + 64) & R ‘以下修改格式
Range(RA).Font.Color = vbBlue
Range(RA).Interior.ThemeColor = xlThemeColorAccent4
Range(RA).Interior.TintAndShade = 0.599963377788629
End If
Next R
AllRange = "A3:" & Chr(NumColumn + 64) & (NumSelected + NumUnselected + 102)
ActiveSheet.AutoFilterMode = False ‘取消筛选状态
Range(AllRange).Sort key1:=Range("A3"), order1:=xlAscending ‘依据序号关键字重新排序
Range("$" & m + 2 & ":$" & m + n + 1).Select ‘选择后还是这个区域选中，只是格式、位置都已经变化了
MsgBox "你选择的志愿项排在预选志愿的第（" & m & "-" & m + n - 1 & "）号：" + vbCrLf + vbCrLf + S, vbOKOnly, "志愿选择提示信息"
End If
End Sub
‘撤销一行的处理：
‘ 1、将所选行后的序号依次减一，并将该行序号改为“待选”
‘ 2、已选值减一（NumSelected = NumSelected - 1），同时改变“目前已选志愿数”所在单元的值，未选值加一
‘ 3、将选中行数据区域的底纹与字体颜色作相应修改
‘ 3、按照预选志愿序号进行排序
‘ 4、最后焦点绝对位置不变
Sub CancelLine(ByVal R As Integer)
Dim KR As Integer, S1 As String, S2 As String, RA As String
Dim AllRange As String, Range1 As String
S1 = Cells(R, 3).Value
S2 = Cells(R, 5).Value
KR = R
Yes = MsgBox("你确定要撤销该预选志愿项吗？" + vbCrLf + vbCrLf + " “" & S1 + " - " + S2 & "”", vbYesNo, "志愿撤销提示信息")
If Yes = vbYes Then
For I = R + 1 To NumSelected + 2
Cells(I, 1).Value = Cells(I, 1).Value - 1 ‘将所选行后的序号依次减一
Next I
Cells(R, 1).Value = "待选" ‘将该行序号改为“待选”
NumSelected = NumSelected - 1 ‘已选数-1
NumUnselected = NumUnselected + 1 ‘未选数+1
Cells(1, 3).Value = NumSelected ‘“目前已选志愿数”单元格赋值
RA = "A" & R & ":" & Chr(NumColumn + 64) & R ‘以下修改格式
Range(RA).Interior.Pattern = xlNone
Range(RA).Font.ColorIndex = xlAutomatic
AllRange = "A3:" & Chr(NumColumn + 64) & (NumSelected + NumUnselected + 102)
Range(AllRange).Sort key1:=Range("A3"), order1:=xlAscending, key2:=Range("B3"), order2:=xlAscending, key3:=Range("D3"), order3:=xlAscending ‘重新排序
For R = 1 To NumSelected
Cells(R + 2, 1).Value = R ‘各序号刷新一遍
Next R
Cells(KR, 1).Select ‘焦点位置设置
End If
End Sub
‘撤销多行的处理：
‘ 1、将所选区域按照行序依次处理：已选值减一，未选值加一，序号改为“待选”，同时改变“目前已选志愿数”所在单元的值，将选中行数据区域的底纹与字体颜色作相应修改
‘ 2、按照预选志愿序号进行排序
‘ 3、从原来选择的撤销区域起始行开始到最后，重新刷新序号
‘ 4、最后焦点定位与原来选择区域的起始行
Sub CancelMultiLines(ByVal R1 As Integer, ByVal R2 As Integer)
Dim n As Integer ‘选中预选志愿项目数
Range1 = "A" & R1 & ":A" & R2
n = Range(Range1).SpecialCells(xlCellTypeVisible).Count
If n > 2 Then
‘超过2项
S = " " + Cells(R1, 3).Value + " - " + Cells(R1, 5).Value + vbCrLf
S = S + " ..............." + vbCrLf
S = S + " " + Cells(R2, 3).Value + " - " + Cells(R2, 5).Value
Else
‘2项
S = " " + Cells(R1, 3).Value + " - " + Cells(R1, 5).Value + vbCrLf
S = S + " " + Cells(R2, 3).Value + " - " + Cells(R2, 5).Value
End If
S1 = "你确定要撤销下列" & n & "个（第" & R1 & "-" & R2 & "行）预选志愿项吗？"
Yes = MsgBox(S1 + vbCrLf + vbCrLf + S, vbYesNo, "志愿撤销提示信息")
If Yes = vbYes Then
For R = R1 To R2 ‘所选区域按行从小到大分别处理
If Range("A" & R).EntireRow.Hidden = False Then
NumSelected = NumSelected - 1 ‘已选数-1
NumUnselected = NumUnselected + 1 ‘未选数+1
Cells(1, 3).Value = NumSelected ‘“目前已选志愿数”单元格赋值
Cells(R, 1) = "待选" ‘将该行序号改为“待选”
RA = "A" & R & ":" & Chr(NumColumn + 64) & R ‘以下修改格式
Range(RA).Interior.Pattern = xlNone
Range(RA).Font.ColorIndex = xlAutomatic
End If
Next R
AllRange = "A3:" & Chr(NumColumn + 64) & (NumSelected + NumUnselected + 102)
ActiveSheet.AutoFilterMode = False
Range(AllRange).Sort key1:=Range("A3"), order1:=xlAscending, key2:=Range("B3"), order2:=xlAscending, key3:=Range("D3"), order3:=xlAscending
For R = 1 To NumSelected
Cells(R + 2, 1).Value = R ‘各序号刷新一遍
Next R
Cells(R1, 1).Select ‘焦点位置设置
End If
End Sub
‘将选中志愿（不超过80项）保存到一个新的Excel工作簿，文档名称为：志愿导入表.xls，保存在预选文件相同的文件夹
Sub SaveAsExcel()
Dim NewSheet As Worksheet, Wb As Workbook
Dim OutputLines As Integer, OutputRange As String
Dim FileName As String
‘计算导出项数：选择项小于80时，用实际项数；选择项大于80项，项数=80
If MaxItem > NumSelected Then OutputLines = NumSelected Else OutputLines = MaxItem
OutputRange = "b3:e" & (OutputLines + 2)
‘将Sheet1表中选中项目的前4列复制到新建表的A2开始的区域中
Worksheets("sheet1").Range(OutputRange).Copy
‘创建新的工作薄
Set Wb = Workbooks.Add
‘当前工作簿的Sheet1表名重命名、将粘贴板内容复制到新工作表中
Set NewSheet = Sheets(1)
NewSheet.Name = "志愿导入表"
Worksheets("志愿导入表").Range("a2").PasteSpecial xlPasteValues
‘设置志愿导入表的各种属性：表头文字、列宽、表格线、字体、字号、行高
Worksheets("志愿导入表").Cells(1, 1).Value = "院校代码" ‘表头文字
Worksheets("志愿导入表").Cells(1, 2).Value = "院校名称" ‘表头文字
Worksheets("志愿导入表").Cells(1, 3).Value = "专业代码" ‘表头文字
Worksheets("志愿导入表").Cells(1, 4).Value = "专业名称" ‘表头文字
Worksheets("志愿导入表").Columns("A:A").ColumnWidth = 12 ‘列宽
Worksheets("志愿导入表").Columns("C:C").ColumnWidth = 12 ‘列宽
Worksheets("志愿导入表").Columns("B:B").ColumnWidth = 35 ‘列宽
Worksheets("志愿导入表").Columns("D:D").ColumnWidth = 50 ‘列宽
Worksheets("志愿导入表").Cells.Select
With Selection.Interior ‘设置表格底纹。最终作用是取消表格线
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Name = "宋体" ‘表格字体
Selection.Font.Size = 12 ‘表格字号
Selection.RowHeight = 20.1 ‘表格行高
Selection.Locked = True ‘ 非志愿数据区锁定
OutputRange = "A1:D" & (OutputLines + 1)
Worksheets("志愿导入表").Range(OutputRange).Select ‘志愿区域表格线
With Selection.Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Worksheets("志愿导入表").Range(OutputRange).Select
Selection.Locked = False ‘志愿数据区不锁定
Worksheets("志愿导入表").Range("A1:D1").Select ‘表头区域底纹
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Selection.HorizontalAlignment = xlCenter ‘表头区域文字居中对齐
Worksheets("志愿导入表").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True ‘设置除锁定区域外操作保护
ActiveSheet.EnableSelection = xlUnlockedCells
‘首行冻结
ActiveWindow.SplitRow = 1
ActiveWindow.FreezePanes = True
Worksheets("志愿导入表").Range("A2").Select ‘新表格打开时焦点设置为A2单元格
FileName = ThisWorkbook.Path + "\志愿导入表.xls"
Application.DisplayAlerts = False ‘取消工作表保存时警告提示
‘工作簿另存为
ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Application.DisplayAlerts = True ‘恢复工作表保存时警告提示
End Sub
[VBA源码] 2018模拟_普通类平行计划1_普通类平行录取_物理化学技术.xlsm
原文：https://www.cnblogs.com/unixart/p/8992269.html