|
- Option Explicit
- Sub Test()
- Dim strType As String, lngCount As Long
- Dim strConditions As String
- Dim arrProblens As Variant, arrAnswer As Variant
-
- '在A表中,提取类型为A的10道题
- strType = "A": lngCount = 20
- If GetProblemsByOneType(strType, lngCount, arrProblens, arrAnswer) = False Then
- Exit Sub
- Else
- Sheet2.Range("E5").Resize(lngCount, 1) = arrProblens
- Sheet2.Range("I5").Resize(lngCount, 1) = arrAnswer
- End If
-
- '在C表中,提取33道题,其中A型10道,B型11道,C型12道,
- strConditions = "A,10;B,11;C,12"
- If GetProblemsByAnyType(strConditions, arrProblens, arrAnswer) = False Then
- Exit Sub
- Else
- Sheet4.Range("E5").Resize(33, 1) = arrProblens
- Sheet4.Range("I5").Resize(33, 1) = arrAnswer
- End If
- End Sub
- '根据指定的类型和数量,从题库中返回试题
- 'strConditions 类型和数量参数,格式为 类型1,数量1;类型2,数量2;类型3,数量3;……类型N,数量N
- 'GetProblemsByAnyType 成功返回True, 失败返回 False
- 'arrProblens 成功,返回试题
- 'arrAnswer 成功,返回答案
- Function GetProblemsByAnyType(ByVal strConditions As String, ByRef arrProblens As Variant, ByRef arrAnswer As Variant) As Boolean
- Dim arrCondtions As Variant, strSplit() As String, strTemp() As String, strAnswer As String
- Dim lngID As Long, strType As String, lngCount As Long, lngSum As Long
- Dim arrP As Variant, arrA As Variant, lngCur As Long, lngRow As Long
-
- strConditions = Trim(strConditions)
- If strConditions = "" Then
- MsgBox "参数输入有误!"
- GetProblemsByAnyType = False
- Exit Function
- End If
-
- strSplit = Split(strConditions, ";")
- ReDim arrCondtions(1 To UBound(strSplit) + 1, 1 To 2)
-
- For lngID = LBound(strSplit) To UBound(strSplit)
- strTemp = Split(strSplit(lngID), ",")
- strType = Trim(strTemp(0))
- lngCount = Val(strTemp(1))
- If strType = "" Or lngCount = 0 Then
- MsgBox "参数输入有误!"
- GetProblemsByAnyType = False
- Exit Function
- End If
- arrCondtions(lngID + 1, 1) = strType
- arrCondtions(lngID + 1, 2) = lngCount
- lngSum = lngSum + lngCount
- Next
-
- ReDim arrProblens(1 To lngSum, 1 To 1)
- ReDim arrAnswer(1 To lngSum, 1 To 1)
- lngCur = 0
-
- For lngID = LBound(arrCondtions) To UBound(arrCondtions)
- strType = arrCondtions(lngID, 1)
- lngCount = arrCondtions(lngID, 2)
- If GetProblemsByOneType(strType, lngCount, arrP, arrA) = False Then
- GetProblemsByAnyType = False
- Exit Function
- Else
- For lngRow = LBound(arrP) To UBound(arrP)
- arrProblens(lngRow + lngCur, 1) = arrP(lngRow, 1)
- arrAnswer(lngRow + lngCur, 1) = arrA(lngRow, 1)
- Next
- lngCur = lngCur + lngRow - 1
- End If
- Next
-
- '乱序
- For lngID = LBound(arrProblens) To UBound(arrProblens)
- lngCur = Int(Rnd * lngSum + 1)
- strType = arrProblens(lngCur, 1)
- strAnswer = arrAnswer(lngCur, 1)
- arrProblens(lngCur, 1) = arrProblens(lngID, 1)
- arrAnswer(lngCur, 1) = arrAnswer(lngID, 1)
- arrProblens(lngID, 1) = strType
- arrAnswer(lngID, 1) = strAnswer
- Next
-
- GetProblemsByAnyType = True
- End Function
- '根据指定的单一类型和数量,从题库中返回试题
- 'strType 类型
- 'lngCount 数量
- 'GetProblemsByOneType 成功返回True, 失败返回 False
- 'arrProblens 成功,返回试题
- 'arrAnswer 成功,返回答案
- Function GetProblemsByOneType(ByVal strType As String, ByVal lngCount As Long, ByRef arrProblens As Variant, ByRef arrAnswer As Variant) As Boolean
- Dim sh As Worksheet, arrData As Variant, lngRow As Long
- Dim arrType As Variant, lngID As Long
- Dim objDIc As Object, strKey As String, lngRND As Long
- Dim arrKeys As Variant, arrItems As Variant
-
- If lngCount < 1 Then
- MsgBox "抽取数量有误!"
- GetProblemsByOneType = False
- Exit Function
- End If
-
- strType = Trim(strType)
- If strType = "" Then
- MsgBox "类型输入有误!"
- GetProblemsByOneType = False
- Exit Function
- End If
-
- Set sh = Sheets("题库")
- arrData = sh.UsedRange
- Set objDIc = CreateObject("scripting.dictionary")
- ReDim arrType(1 To UBound(arrData), 1 To 2)
- lngID = 0
-
- For lngRow = LBound(arrData) To UBound(arrData)
- If Trim(arrData(lngRow, 1)) Like strType & "*" Then
- lngID = lngID + 1
- arrType(lngID, 1) = arrData(lngRow, 2)
- arrType(lngID, 2) = arrData(lngRow, 3)
- strKey = Trim(arrData(lngRow, 3))
- objDIc(strKey) = ""
- End If
- Next
-
- If lngCount > objDIc.Count Then
- MsgBox "【" & strType & "】型题可抽题目不足!"
- GetProblemsByOneType = False
- Exit Function
- End If
-
- ReDim arrProblens(1 To lngCount, 1 To 1)
- ReDim arrAnswer(1 To lngCount, 1 To 1)
- objDIc.RemoveAll
-
- Do Until objDIc.Count = lngCount
- lngRND = Int(Rnd * lngID + 1)
- strKey = arrType(lngRND, 2)
- objDIc(strKey) = arrType(lngRND, 1)
- Loop
-
- arrKeys = objDIc.keys
- arrItems = objDIc.items
-
- Set objDIc = Nothing
-
- For lngID = LBound(arrKeys) To UBound(arrKeys)
- arrProblens(lngID + 1, 1) = arrItems(lngID)
- arrAnswer(lngID + 1, 1) = arrKeys(lngID)
- Next
- GetProblemsByOneType = True
- End Function
复制代码 |
|