[VBA源码] 2018模拟_普通类平行计划1_普通类平行录取_物理化学技术.xlsm

Posted 2020-11-02 Code Art

测试了下浙江省教育考试院给的2018年模拟演练（志愿填报）文件，发现bug颇多，想自行修改下VBA代码，却发现VBA有项目密码，不想就此停手，故参考网上的相关资料将VBA源码提取出来，附于此处，方便有需要者自行改进代码逻辑，仅供学习研究使用，请勿用于商业用途，如有违反后果自负，版权及解释权归浙江省教育考试院所有。

为了避免不必要的麻烦，文件下载和密码问题请自行解决，本处仅提供源码。

文件来自:浙江省高校招生志愿填报系统(模拟)

---

VBAProject

Microsoft Excel 对象

Sheet1

‘工作表单元格的值发生改变，触发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

ThisWorkBook

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

模块

模块1

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