[VBA Source code] 2018 Simulation _ Common class parallel plan 1_ general class parallel admission _ Physical chemistry technology. xlsm

Test the next Zhejiang Provincial Education Examination Institute for the 2018-year simulation exercise (volunteer) file, found a lot of bugs, want to modify the VBA code, but found that VBA has a project password, do not want to stop, so refer to the relevant information on the Web will be VBA source code extracted, attached here, For the convenience of the need to improve the code logic, only for learning research use, do not use for commercial purposes, if there is a breach of the consequences, copyright and interpretation of the rights of the Zhejiang Provincial Education Examination Institute .

In order to avoid unnecessary trouble, the file download and password problems, please resolve their own, the department only provide source code.

File from: Zhejiang Province University enrollment Volunteer System (simulation)

Vbaprojectmicrosoft Excel Object Sheet1

' The value of the worksheet cell changes to trigger the Worksheet_change event ' target to a changed cell or range ' Application.enableevents = False to indicate that events such as cell changes will not trigger an event procedure, avoiding No "dead loop" ' application.enableevents = True ' restore normal event procedure ' only if the cell changes in the 1th column, the other case of undo, that is, the value does not allow to change the value of column 1th is changed in two cases: (only the value is greater than or equal to 1 is considered reasonable, more than the currently selected number default is equal to the selected ordinal maximum +1) ' 1, the original has been selected, the value changes, select the sequence number to adjust, reorder ' 2, the original "to be selected", the value changes, reorder ' processing sorting problem by resort ' P Rivate 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 ' detects that the 1th column is a unary operation 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 "Please enter an integer not less than 1!" ", vbcritical," Ordinal error message "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 "Please enter an integer not less than 1!" ", vbcritical," Serial number error message "' Target '. Value = "Pending" End If else Application.undo end If else Application.undo En D If application.enableevents = TrueEnd Sub ' cell focus is changed, generally select cell operation ' original in this cell, then click the mouse to select this cell, this situation does not trigger the event 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 ' determines the condition of the selected row R = target. Row if R > 2 and R <= numunselected + numselected + 2 Then ' to determine if the Cell is within the range of the project line S (R, 1). Value = "To be selected" Then ' only 1th column ' pending ' or value >=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 ' judging the condition of selecting multiple rows ' continuous multi-line processing 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 Cancelmultil Ines R1, R2 End If End if ElseIf target.    Address = "$L $: $M" then "Automatically save import document processing If numselected = 0 Then MsgBox" Currently selected volunteer = 0, do not generate volunteer documents! "+ vbCrLf + vbCrLf, vbcritical," Auto Generate voluntary document Prompt "Else Yes = MsgBox (" The system will select the volunteer (top 80 items) to save to ' voluntary import table. xls ' Document "+ vbcr Lf + vbCrLf + vbTab + vbTab + "Are you sure you want to continue?"  ", vbquestion + vbYesNo," Auto generate voluntary document hint ") If Yes = vbyes Then              Saveasexcel MsgBox "Volunteer document" Volunteer import table. xls "has been successfully generated!" "+ vbCrLf + vbCrLf +" volunteer document saved in the folder of this workbook document ", vbinformation," Automatically generate voluntary document Tips "End If End if Workshee TS ("Sheet1"). Range ("A2"). Select End If application.enableevents = TrueEnd 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

Module Module 1

Public numunselected as Long, numselected as Longpublic Numcolumn as Longpublic MaxItem as Integersub vbainitlize () ' first two    Line Freeze MaxItem = 80 ' regular batch up to 80 volunteer Activewindow.splitcolumn = 0 Activewindow.splitrow = 2 Activewindow.freezepanes = True application.enableevents = False ' event invalidation: A statement that changes cell values during the recount event raises the change event. This statement is used to mask the occurrence of an event recount application.enableevents = True ' event available in Range ("A1").        Select ' Open the form after focus in A1 cell end Sub ' calculates several important data: Selected quantity, selected quantity, number of active columns ' statistics selected volunteer number numselected:3-30000 row statistics 1th column is greater than or equal to 1  Statistics of the number of numunselected:3-30000 in the 1th column, the number of "pending" Statistics valid columns Numcolumn: The 2nd Column non-empty item ' 1th row 3rd column shows the number of options ' 1th row 6th column shows the total number of items sub Recount () numselected = Application.WorksheetFunction.CountIf (Range ("a3:a30000"), ">=1") ' Number of options ' numunselecte D = Application.WorksheetFunction.CountIf (Range ("a3:a30000"), "pending") ' Not selected ' number Numcolumn = Application.worksheetfunction.c Ountif (Cells (3, 1). EntireRow, "<>") ' Effective column of Cells (1, 3). ValuE = numselected ' Number of options Cells (1, 6). Value = numunselected + numselected ' Total number of items end Sub ' re-ordering the design idea: ' 1, for the new serial number to make room, that is, all the serial number after the newly-serial number is added 1, so that the new serial number is the only ' 2, reorder by ordinal, which is called after the completion of the internal process of Excel ' 3, after sorting, renumber ' reorder in 2 cases ' 1, enter a valid ordinal (greater than or equal to 1) ' 2 in the selected area, enter a valid order in the Number (greater than or equal to 1) ' key is the input ordinal, R is the line number, C is the column number sub ReSort (ByVal R as Long, ByVal C as Long, Key as Long) Dim S1 as String, S2 as St Ring S1 = Cells (R, 3). Value ' The name of the institution for which the item is to be changed for the popup message hint S2 = Cells (R, 5).        Value ' The professional name of the item to be changed for the popup message prompt for I = Key to numselected ' change sequence number: Starting from key to the previously selected number, ordinal +1; if Key is greater than the selected number, the loop skips and does not execute Cells (I + 2, 1). Value = I + 1 ' This leaves space for the new sequence number Next I Cells (R, C).                    Value = Key ' may have been "changed" during the above change sequence RA = "a" & R & ":" & Chr (Numcolumn + +) & R ' Prepare to change format Range (RA). Font.Color = Vbblue Range (RA). Interior.themecolor = XlThemeColorAccent4 Range (RA). Interior.tintandshaDe = 0.599963377788629 Allrange = "A3:" & Chr (Numcolumn + +) & (numselected + numunselected + 102) Range (Al Lrange). Sort Key1:=range ("A3"), order1:=xlascending ' reorder if R > numselected + 2 Then ' to determine whether the new selection: if it is a new selection, select the number + 1, not selected-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 ' Each sequence number is refreshed again next I If key > numselected then key = numselected Cells (Key + 2, 1).  Entirerow.select ' focus remains on the line that just changed the serial number MsgBox "The volunteer you selected is in the pre-selection volunteer (" & Key & ") Number:" + vbCrLf + vbCrLf + "" "& S1 + "-" + S2 & "" ", vbOKOnly," Volunteer selection Tip "End Sub ' processing of the selected line: ' 1, Original is the selected line, change" to select "to the last preselection value (numselected = numselected +  1), at the same time, change the "currently selected number of volunteers" unit value ' 2, the selected row data region shading and font color for the corresponding modification of ' 3, according to the pre-selection of the number of voluntary sequence ' 4, the final focus on the bank, but the position, the format has changed sub SelectItem (ByVal R As Integer) S1 = Cells (R, 3). Value S2 = Cells (R, 5). Value Yes = MsgBox ("Are you sure you want to select the followingProject as a pre-selection volunteer? "+ vbCrLf + vbCrLf +" "" "& S1 +"-"+ S2 &" "", vbYesNo, "voluntary selection prompt") If Yes = vbyes Then Numsel ected = numselected + 1 ' selected value +1 numunselected = NumUnselected-1 ' not selected -1 Cells (1, 3).  Value = Numselected ' Currently selected number of volunteers ' cell assignment cells (R, 1) = Numselected ' selected line assigned the latest sequence number RA = "A" & R & ":" & Chr (Numcolumn + +) & R ' below change format Range (RA). Font.Color = Vbblue Range (RA). Interior.themecolor = XlThemeColorAccent4 Range (RA). Interior.tintandshade = 0.599963377788629 Allrange = "A3:" & Chr (Numcolumn + +) & (numselected + Numunsele CTED + 102) Range (Allrange). Sort Key1:=range ("A3"), order1:=xlascending ' re-sort Cells (numselected + 2, 1).  Entirerow.select MsgBox "Your choice of volunteering in the pre-selected volunteer (" & numselected & ") Number:" + vbCrLf + vbCrLf + "" "& S1 +" -"+ S2 &" "", vbOKOnly, "Volunteer selection Tip" End ifend Sub ' Select multi-line processing: ' 1, Original is the selected area, change "pending" to the last itemPreselection value (numselected = numselected + 1), while changing the value of the unit of the selected value ' 2, the selected row data region of the shading and font color for the corresponding modification ' 3, according to the pre-selection of the number of voluntary sequence ' 4, the final focus on the selected area, just position, lattice    "5, multiline selection can be a sub Selectmultittems (ByVal R1 As Integer, ByVal R2 As Integer) in the" Filter "state, Dim N as Long ' selected number of volunteers              Dim m As Long, R as Long Dim Allrange as String, Range1 as String, S as String m = numselected + 1 ' Selected item start ordinal Range1 = ' a ' & R1 & ': A ' & R2 ' selected area n = Range (Range1). SpecialCells (xlcelltypevisible). Count ' calculates the number of rows N. No use N=abs (R2-R1) +1 calculation is considered in the selection of the case of the choice problem If n > 2 Then ' line number is different, the hint way slightly different ' more than 2 lines S = ' + Cells (R1, 3). V Alue + "-" + Cells (R1, 5). Value + vbCrLf s = s + "...", "+ vbCrLf s = s +" "+ Cells (R2, 3). Value + "-" + Cells (R2, 5). Value Else ' 2 line S = "" + Cells (R1, 3). Value + "-" + Cells (R1, 5). Value + vbCrLf s = s + "" + Cells (R2, 3). Value + "-" + Cells (R2, 5). Value End If S1 = "Are you sure you want to select the following" & N &amP "(Section & R1 &" ... "& R2 &" line) project as a pre-selection volunteer?            "Yes = MsgBox (S1 + vbCrLf + vbCrLf + S, vbYesNo," volunteer selection Prompt ") If Yes = vbyes Then for R = R1 to R2 If Range ("A" & R).                               Entirerow.hidden = False Then ' is not handled for hidden rows in the filter case, the following is a one-line process numselected = numselected + 1                ' Selected number +1 numunselected = NumUnselected-1 ' Not selected-1 Cells (1, 3).                                   Value = Numselected ' Currently selected number of volunteers ' cell assignment cells (R, 1) = numselected ' The selected line is assigned the latest sequence number RA = "A" & R & ":" & Chr (Numcolumn + +) & R ' under Repair Change Format 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 ' de-filter status Range (Allrange) . Sort Key1:=range ("A3"), order1:=xlascending ' reorder Range based on ordinal key ("$" & M + 2 & ": $" & M + N + 1). Select ' Selection or this area is selected, but the format, the location has changed MsgBox "Your choice of volunteers ranked in the pre-selection volunteer (" & M & "-" & M + n-1 &A mp ") Number:" + vbCrLf + vbCrLf + S, vbOKOnly, "Voluntary selection tip" End IfEnd Sub ' undo a line of processing: ' 1, subtract the ordinal of the selected line by one, and change the line number to "pending" ' 2, the selected value minus one ( numselected = NumSelected-1), at the same time change the "currently selected number of volunteers" in the unit of the value, not selected value plus a ' 3, the selected row data region shading and font color for the corresponding modification of ' 3, according to the pre-selection of the number of volunteers to sort ' 4, the final focus absolute position does not Variable Sub Cancelline (ByVal R As Integer) Dim KR As Integer, S1 as String, S2 as String, RA As String Dim allrange as Stri Ng, Range1 as String S1 = Cells (R, 3). Value S2 = Cells (R, 5). Value KR = R Yes = MsgBox ("Are you sure you want to revoke the preselected volunteer?") "+ vbCrLf + vbCrLf +" "" "& S1 +"-"+ S2 &" "", vbYesNo, "voluntary undo message") If Yes = vbyes Then for I = R + 1 to numselected + 2           Cells (I, 1). Value = Cells (I, 1). Value-1 ' will subtract the ordinal of the selected line by one next I Cells (R, 1).        Value = "Pending" Changes the line number to "pending" numselected = NumSelected-1 ' Selected number-1 numunselected = numunselected + 1 ' not selected number +1 Cells (1, 3). Value = Numselected ' currently selected volunteer ' cell assignment RA = ' A ' & R & ': ' & Chr (Numcolumn + +) & Modify the Format Range (RA) below R '. Interior.Pattern = Xlnone Range (RA).        Font.ColorIndex = xlautomatic Allrange = "A3:" & Chr (Numcolumn + +) & (numselected + numunselected + 102) Range (Allrange). Sort Key1:=range ("A3"), Order1:=xlascending, Key2:=range ("B3"), Order2:=xlascending, Key3:=range ("D3"), order3:= Xlascending ' reorder for r = 1 to numselected Cells (R + 2, 1). Value = R ' Each sequence number is refreshed again next R Cells (KR, 1). Select ' focus position setting End IfEnd Sub ' undo Multiline Processing: ' 1, the selected area is processed sequentially: The selected value is reduced by one, the selected value is addedFirst, the serial number is changed to "Pending", at the same time change the "currently selected number of volunteers" unit value, the selected row data area of the shading and font color for the corresponding modification ' 2, according to the pre-selection of the number of volunteers to sort ' 3, from the original choice of the cancellation of the starting line to the end, re-refresh Select the starting line of the range sub Cancelmultilines (ByVal R1 As Integer, ByVal R2 as Integer) Dim n As Integer ' Select the number of volunteer items Range1 = ' A "& R1 &": a "& R2 n = Range (Range1). SpecialCells (xlcelltypevisible). Count If n > 2 Then ' more than 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 Items S = "" + Cells (R1, 3). Value + "-" + Cells (R1, 5). Value + vbCrLf s = s + "" + Cells (R2, 3). Value + "-" + Cells (R2, 5). Value End If S1 = "Are you sure you want to revoke the following & N &" ("& R1 &"-"& R2 &" lines) to pre-select a volunteer?                            "Yes = MsgBox (S1 + vbCrLf + vbCrLf + S, vbYesNo," voluntary revocation prompt ") If Yes = vbyes Then for R = R1 to R2            ' Selected areas are processed from small to large by rowIf Range ("A" & R). Entirerow.hidden = False Then numselected = NumSelected-1 ' selected number-1 numunselected = Num Unselected + 1 ' not selected +1 Cells (1, 3). Value = Numselected ' Currently selected number of volunteers ' cell assignment cells (R, 1) = "Pending" will change the line number to "pending" RA = "A" & R & ":" & Chr (Numcolumn + +) & R ' below modify format Range (RA). Interior.Pattern = Xlnone Range (RA). Font.ColorIndex = xlautomatic End If Next R allrange = "A3:" & Chr (Numcolumn + +) & (Num Selected + 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 ' Each sequence number is refreshed again next R Cells (R1, 1). Select ' Focus position setting End IfEnd Sub ' will be selected for volunteering (no more than 80 items) to be saved to a new excEl Workbook, the document name is: Volunteer import table. xls, saved in the same folder as the preselection file sub Saveasexcel () Dim newsheet As Worksheet, Wb as Workbook Dim outputlines As in  Teger, Outputrange As String Dim FileName As String ' calculation of the number of exported items: the selection is less than 80 o'clock, with the actual number of items, the item is greater than 80 items, the number of items =80 If maxitem >    numselected then Outputlines = numselected Else outputlines = MaxItem Outputrange = "B3:e" & (Outputlines + 2) ' Copy the first 4 columns of the selected items in the Sheet1 table to the area where the A2 of the new table starts worksheets ("Sheet1"). Range (Outputrange). Copy ' Create new workbook set Wb = Workbooks.Add ' Sheet1 table name of current workbook rename, copy pasteboard contents to new sheet Set newsheet = Sheets (1) Newshee T.name = "Volunteer Import Table" Worksheets ("Voluntary import Table"). Range ("A2"). PasteSpecial xlpastevalues ' Sets the various properties of the Volunteer Import table: Header text, column width, table line, font, size, line height worksheets ("Volunteer Import Table"). Cells (1, 1). Value = "Institution Code" header text Worksheets ("Volunteer Import Table"). Cells (1, 2). Value = "Institution name" Header text Worksheets ("Volunteer Import Table"). Cells (1, 3). Value = "Professional Code" header text Worksheets ("Volunteer Import Table"). Cells (1, 4). Value = "Professional name" header text Worksheets ("Volunteer Import Table"). Columns ("A:a"). ColumnWidth = 12 ' column width WorksheetS ("Voluntary import Table"). Columns ("C:c"). ColumnWidth = 12 ' column width worksheets ("Voluntary import Table"). Columns ("B:b"). ColumnWidth = 35 ' Column width worksheets ("Voluntary import Table"). Columns ("D:d"). ColumnWidth = 50 ' column width worksheets ("Voluntary import Table"). Cells.select with Selection.interior ' Set table shading. The final function is to cancel the table line. Pattern = Xlsolid. Patterncolorindex = xlautomatic. ThemeColor = XlThemeColorDark1. TintAndShade = 0. Patterntintandshade = 0 End with Selection.Font.Name = "Arial" ' Table font Selection.Font.Size = 12 ' Table font size Sel Ection.  RowHeight = 20.1 ' table row height selection.locked = True ' non-voluntary data area lock Outputrange = ' a1:d ' &    (Outputlines + 1) Worksheets ("Voluntary import Table"). Range (Outputrange). Select ' volunteer area form line with Selection.borders. LineStyle = xlcontinuous. ColorIndex = xlautomatic. TintAndShade = 0. Weight = Xlthin End with Worksheets ("Voluntary import Table"). Range (Outputrange). Select selection.locked = False ' voluntary data area not locked    Worksheets ("Voluntary import Table"). Range ("A1:d1"). Select ' header area shading with Selection.interior. Pattern = Xlsolid. Patterncolorindex = xlautomatic. ThemeColor = XlThemeColorAccent6. TintAndShade = 0.799981688894314. Patterntintandshade = 0 End with selection.horizontalalignment = Xlcenter ' header area Text Center align Worksheets ("Volunteer Import Table "). Select ActiveSheet.Protect Drawingobjects:=true, contents:=true, Scenarios:=true ' set aside from locked area operation Protection activesheet.enable Selection = xlUnlockedCells ' first line freezes Activewindow.splitrow = 1 Activewindow.freezepanes = True Worksheets ("Volunteer Import Table" ). Range ("A2").                  Select ' New table opens with focus set to A2 cell FileName = thisworkbook.path + "\ Volunteer import table. xls" Application.DisplayAlerts = False ' Cancel sheet Save alert prompt ' workbook saved as ActiveWorkbook.SaveAs Filename:=filename, Fileformat:=xlnormal, password:= ' ", writ Erespassword:= "", Readonlyrecommended:=false, createbackup:=false activeworkbook.close Application.DisplayAlerts = T     Rue              ' Restore worksheet save warning prompt end Sub 

[VBA Source code] 2018 Simulation _ Common class parallel plan 1_ general class parallel admission _ Physical Chemistry technology. XLSM