VBA模拟题库生成器

Option ExplicitDim intXZ As Integer    '选择题数
Dim intPD As Integer    '判断题数
Dim intTK As Integer    '填空题数
Dim intWD As Integer    '问答题数
Dim intNon As Integer    '未知题数
Dim intCount As Integer '题库行数
Dim intCol As Integer     '岗位项所在列号
Dim intSelrow As Long  '随机选择的行
Dim intYX() As Long    '已选过的行
Dim intTMS As Integer '试卷题目数Private Function GetROW() As Integer '不重复的随机行Dim a As LongDim j As LongRandomizeReSel:a = Int(Rnd * intCount + 1)For j = 1 To intTMS - 1If intYX(j) = a Then GoTo ReSel'Exit ForNext jGetROW = aEnd FunctionPrivate Sub CountTM(strGW As String)
'计算题目数Dim i As IntegerintCol = Application.WorksheetFunction.Match(strGW, Sheet1.Range("A3:X3"), 0)Me.Caption = "正在计算各类题数..."intXZ = 0
intPD = 0
intTK = 0
intWD = 0
intNon = 0On Error Resume Next
With Sheet1For i = 4 To intCountIf UCase(.Cells(i, intCol)) = "Y" Then   '是所要的Select Case .Cells(i, 3)Case "选择"intXZ = intXZ + 1Case "判断"intPD = intPD + 1Case "填空"intTK = intTK + 1Case "问答"intWD = intWD + 1Case ElseintNon = intNon + 1End SelectEnd IfNext
End With
Me.Caption = "试卷生成器(Rev#20060401)"End SubPrivate Sub cmdCancel_Click()frmPaper.HideUnload frmPaper
End SubPrivate Sub cmdOK_Click()'检测是否选择岗位If comPst.ListIndex = -1 Then MsgBox "请选择岗位...", vbCritical, "参数不全": Exit SubCall CountTM(comPst.Value) '计算题目数If CInt(txt11) > intXZ Or CInt(txt21) > intPD Or CInt(txt31) > intTK Or CInt(txt41) > intWD ThenMsgBox "你输入的题数不能大于题库总数:" & vbCrLf & vbCrLf _& "选择题有: " & intXZ & " 题" & vbCrLf _& "判断题有: " & intPD & " 题" & vbCrLf _& "填空题有: " & intTK & " 题" & vbCrLf _& "问答题有: " & intWD & " 题" & vbCrLf _& "未知题型: " & intNon & " 题", vbInformation + vbOKOnly, "题源不足"Exit SubEnd IfintTMS = CInt(txt11) + CInt(txt21) + CInt(txt31) + CInt(txt41)ReDim intYX(intTMS)Application.ScreenUpdating = FalseMe.Caption = "试卷生成器 >>正在检测数据，请稍后...."Sheet2.Unprotect "2007"Dim strTitle As StringDim intDot As Integer'填写表头,识别中英文intDot = InStr(1, txtTitle, ",", vbTextCompare)If intDot <= 0 ThenstrTitle = txtTitleElsestrTitle = Mid(txtTitle, 1, intDot - 1) & Chr(10) & Mid(txtTitle, intDot + 1, Len(txtTitle))End If'初始化表格With Sheet2.Range("B6:B5004").EntireRow.Delete.Range("A2") = strTitleWith Range("A2").Characters(Start:=1, Length:=intDot).Font.Size = 18.Characters(Start:=intDot + 1, Length:=Len(strTitle) - intDot).Font.Size = 10End With.Range("I2") = "PaperID: " & Format(Now(), "yymmdd-hhmm").Range("C4") = comPst.Value.Range("I4") = "考时: " & txtHour & "分钟" & Chr(10) & "Exam time limit " & txtHour & " minutes"With Range("i4")intDot = InStr(1, .Value, "分", vbTextCompare).Characters(Start:=1, Length:=intDot).Font.Size = 10.Characters(Start:=intDot + 1, Length:=Len(.Value) - intDot).Font.Size = 8End WithstrTitle = "": intDot = 0  '变量复位End WithMe.Caption = "试卷生成器 >>正在计算题库，请稍后...."'选择并填充题目Dim XZ As IntegerDim XZ2 As IntegerDim PD As IntegerDim PD2 As IntegerDim TK As IntegerDim TK2 As IntegerDim WD As IntegerDim WD2 As IntegerDim m As Integer, n As Integer '循环题数标题变量Dim strGW As String   '岗位Dim strTL As String   '题类Dim strTM As String   '题目Dim strXX As String   '选项Dim ok As Long '有效题行号'依次完成选择 , 判断, 填空, 简述题n = 1For m = 1 To 4Select Case mCase 1XZ = 6 + nCase 2PD = 6 + nCase 3TK = 6 + nCase 4WD = 6 + nEnd SelectIf Me("txt" & m & "1") > 0 ThenWith Sheet2.Cells(5 + n, 2)MergeRow CInt(5 + n)n = n + 1 + IIf(m = 1, txt11.Value * 2, Me("txt" & m & "1").Value).Value = Me("lbl" & m).Caption & "  " & Me("txt" & m & "3") & "   共 " & Me("txt" & m & "1") & " 题, 每题 " & Me("txt" & m & "2") & " 分".RowHeight = 32.25.Font.Size = 14.Interior.Color = vbYellowEnd WithEnd IfNextMe.Caption = "试卷生成器 >>正在随机选题，请稍后...."'随机选择题目XZ2 = CInt(txt11 * 2 + XZ)PD2 = CInt(txt21 + PD)TK2 = CInt(txt31 + TK)WD2 = CInt(txt41 + WD)ok = 0'只能在同一时间选择好:题类,题目,岗位Do Until XZ >= XZ2 And PD >= PD2 And TK >= TK2 And WD >= WD2DoEvents'获得不重复的随机行号intSelrow = GetROWWith Sheet1strGW = UCase(CStr(.Cells(intSelrow, intCol)))strTL = CStr(.Cells(intSelrow, 3))strTM = CStr(.Cells(intSelrow, 5))strXX = CStr(.Cells(intSelrow, 6))End WithWith Sheet2If strGW = "Y" ThenintYX(ok) = intSelrowSelect Case strTLCase "选择"If XZ2 = 0 Or XZ >= XZ2 ThenElse.Cells(XZ, 2).Value = strTMMergeRow XZ.Cells(XZ + 1, 2).Value = strXXMergeRow XZ + 1If .Cells(XZ - 2, 1) = "" Then .Cells(XZ, 1) = 1 Else .Cells(XZ, 1) = .Cells(XZ - 2, 1) + 1XZ = XZ + 2ok = ok + 1End IfCase "判断"If PD2 = 0 Or PD >= PD2 ThenElse.Cells(PD, 2).Value = strTMMergeRow PDIf .Cells(PD - 1, 1) = "" Then .Cells(PD, 1) = 1 Else .Cells(PD, 1) = .Cells(PD - 1, 1) + 1PD = PD + 1ok = ok + 1End IfCase "填空"If TK2 = 0 Or TK >= TK2 ThenElse.Cells(TK, 2).Value = strTMMergeRow TKIf .Cells(TK - 1, 1) = "" Then .Cells(TK, 1) = 1 Else .Cells(TK, 1) = .Cells(TK - 1, 1) + 1TK = TK + 1ok = ok + 1End IfCase "问答"If WD2 = 0 Or WD >= WD2 ThenElse.Cells(WD, 2).Value = strTMMergeRow WDIf .Cells(WD - 1, 1) = "" Then .Cells(WD, 1) = 1 Else .Cells(WD, 1) = .Cells(WD - 1, 1) + 1WD = WD + 1ok = ok + 1End IfEnd SelectEnd IfEnd WithMe.Caption = "试卷生成器 >>正在随机选题....(" & Int(ok / intTMS * 100) & "% OK)"LoopMe.Caption = "试卷生成器 >>正在优化格式，请稍后...."Sheet2.SelectSheet2.Columns(1).AutoFitSheet2.Columns(1).HorizontalAlignment = xlLeftRange("A2").CurrentRegion.SelectFor m = 7 To 10 Step 1With Selection.Borders(m).LineStyle = xlContinuous.Weight = xlMedium.ColorIndex = xlAutomaticEnd WithNextRange("c4").SelectActiveWindow.DisplayGridlines = FalseSheet2.Protect "2007"Application.ScreenUpdating = TrueCall cmdCancel_ClickEnd Sub
Private Sub MergeRow(intSelrow As Integer)With Sheet2.Range(Cells(intSelrow, 2), Cells(intSelrow, 9)).MergeCells = True.HorizontalAlignment = xlLeft.VerticalAlignment = xlCenter.WrapText = True.EntireRow.AutoFitEnd With
End Sub
Private Sub UserForm_Initialize()'初始化岗位Dim rngPostion As Range, i As IntegertxtTitle = Sheet1.Range("a1")For Each rngPostion In Sheet1.Range("$G$3:$X$3")If rngPostion <> "" ThencomPst.AddItem rngPostion.Value, ii = i + 1End IfNextintCount = Application.WorksheetFunction.CountA(Sheet1.Range("E4:E5004")) + 3  '已输入的有效行数End Sub