[VBA源碼] 2018模擬_普通類平行計劃1_普通類平行錄取_物理化學技術.xlsm
阿新 • • 發佈：2018-05-04
.net 密碼 字號 發生 作文 表示 html tint CI
測試了下浙江省教育考試院給的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
[VBA源碼] 2018模擬_普通類平行計劃1_普通類平行錄取_物理化學技術.xlsm