从一列中不重复地随机提取文本，文本有相同的，但所指内容不同。（难，见文件可知）

zjjEH

一把小刀闯天下 发表于 2019-8-2 09:05
'a:c20,h8,b10,a2   -->输出A工作表，20个C类题，8个H类题，，，合计必须为40

Option Explicit

谢谢大师，佩服。想问一下，能在答案前把分类号中上去吗。

一把小刀闯天下

zjjEH 发表于 2019-8-2 10:15
谢谢大师，佩服。想问一下，能在答案前把分类号中上去吗。

为了测试用的，忘了去除了

arr(m, 1) = data(a, 1) & data(a, 2)

改成：
arr(m, 1) = data(a, 2)

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim strType As String, lngCount As Long
   
5.     Dim strConditions As String
   
6.     Dim arrProblens As Variant, arrAnswer As Variant
   
7.    
   
8.     '在A表中，提取类型为A的10道题
   
9.     strType = "A": lngCount = 20
   
10.     If GetProblemsByOneType(strType, lngCount, arrProblens, arrAnswer) = False Then
    
11.         Exit Sub
    
12.     Else
    
13.         Sheet2.Range("E5").Resize(lngCount, 1) = arrProblens
    
14.         Sheet2.Range("I5").Resize(lngCount, 1) = arrAnswer
    
15.     End If
    
16.    
    
17.     '在C表中，提取33道题，其中A型10道,B型11道,C型12道,
    
18.     strConditions = "A,10;B,11;C,12"
    
19.     If GetProblemsByAnyType(strConditions, arrProblens, arrAnswer) = False Then
    
20.         Exit Sub
    
21.     Else
    
22.         Sheet4.Range("E5").Resize(33, 1) = arrProblens
    
23.         Sheet4.Range("I5").Resize(33, 1) = arrAnswer
    
24.     End If
    
25. 
    
26. End Sub
    
27. 
    
28. '根据指定的类型和数量，从题库中返回试题
    
29. 'strConditions 类型和数量参数，格式为  类型1,数量1;类型2,数量2;类型3,数量3;……类型N,数量N
    
30. 'GetProblemsByAnyType 成功返回True, 失败返回 False
    
31. 'arrProblens 成功，返回试题
    
32. 'arrAnswer 成功，返回答案
    
33. Function GetProblemsByAnyType(ByVal strConditions As String, ByRef arrProblens As Variant, ByRef arrAnswer As Variant) As Boolean
    
34.     Dim arrCondtions As Variant, strSplit() As String, strTemp() As String, strAnswer As String
    
35.     Dim lngID As Long, strType As String, lngCount As Long, lngSum As Long
    
36.     Dim arrP As Variant, arrA As Variant, lngCur As Long, lngRow As Long
    
37.    
    
38.     strConditions = Trim(strConditions)
    
39.     If strConditions = "" Then
    
40.         MsgBox "参数输入有误！"
    
41.         GetProblemsByAnyType = False
    
42.         Exit Function
    
43.     End If
    
44.    
    
45.     strSplit = Split(strConditions, ";")
    
46.     ReDim arrCondtions(1 To UBound(strSplit) + 1, 1 To 2)
    
47.    
    
48.     For lngID = LBound(strSplit) To UBound(strSplit)
    
49.         strTemp = Split(strSplit(lngID), ",")
    
50.         strType = Trim(strTemp(0))
    
51.         lngCount = Val(strTemp(1))
    
52.         If strType = "" Or lngCount = 0 Then
    
53.             MsgBox "参数输入有误！"
    
54.             GetProblemsByAnyType = False
    
55.             Exit Function
    
56.         End If
    
57.         arrCondtions(lngID + 1, 1) = strType
    
58.         arrCondtions(lngID + 1, 2) = lngCount
    
59.         lngSum = lngSum + lngCount
    
60.     Next
    
61.    
    
62.     ReDim arrProblens(1 To lngSum, 1 To 1)
    
63.     ReDim arrAnswer(1 To lngSum, 1 To 1)
    
64.     lngCur = 0
    
65.    
    
66.     For lngID = LBound(arrCondtions) To UBound(arrCondtions)
    
67.         strType = arrCondtions(lngID, 1)
    
68.         lngCount = arrCondtions(lngID, 2)
    
69.         If GetProblemsByOneType(strType, lngCount, arrP, arrA) = False Then
    
70.             GetProblemsByAnyType = False
    
71.             Exit Function
    
72.         Else
    
73.             For lngRow = LBound(arrP) To UBound(arrP)
    
74.                 arrProblens(lngRow + lngCur, 1) = arrP(lngRow, 1)
    
75.                 arrAnswer(lngRow + lngCur, 1) = arrA(lngRow, 1)
    
76.             Next
    
77.             lngCur = lngCur + lngRow - 1
    
78.         End If
    
79.     Next
    
80.    
    
81.     '乱序
    
82.     For lngID = LBound(arrProblens) To UBound(arrProblens)
    
83.         lngCur = Int(Rnd * lngSum + 1)
    
84.         strType = arrProblens(lngCur, 1)
    
85.         strAnswer = arrAnswer(lngCur, 1)
    
86.         arrProblens(lngCur, 1) = arrProblens(lngID, 1)
    
87.         arrAnswer(lngCur, 1) = arrAnswer(lngID, 1)
    
88.         arrProblens(lngID, 1) = strType
    
89.         arrAnswer(lngID, 1) = strAnswer
    
90.     Next
    
91.    
    
92.     GetProblemsByAnyType = True
    
93. End Function
    
94. 
    
95. 
    
96. '根据指定的单一类型和数量，从题库中返回试题
    
97. 'strType 类型
    
98. 'lngCount 数量
    
99. 'GetProblemsByOneType 成功返回True, 失败返回 False
    
100. 'arrProblens 成功，返回试题
     
101. 'arrAnswer 成功，返回答案
     
102. Function GetProblemsByOneType(ByVal strType As String, ByVal lngCount As Long, ByRef arrProblens As Variant, ByRef arrAnswer As Variant) As Boolean
     
103.     Dim sh As Worksheet, arrData As Variant, lngRow As Long
     
104.     Dim arrType As Variant, lngID As Long
     
105.     Dim objDIc As Object, strKey As String, lngRND As Long
     
106.     Dim arrKeys As Variant, arrItems As Variant
     
107.    
     
108.     If lngCount < 1 Then
     
109.         MsgBox "抽取数量有误！"
     
110.         GetProblemsByOneType = False
     
111.         Exit Function
     
112.     End If
     
113.    
     
114.     strType = Trim(strType)
     
115.     If strType = "" Then
     
116.         MsgBox "类型输入有误！"
     
117.         GetProblemsByOneType = False
     
118.         Exit Function
     
119.     End If
     
120.    
     
121.     Set sh = Sheets("题库")
     
122.     arrData = sh.UsedRange
     
123.     Set objDIc = CreateObject("scripting.dictionary")
     
124.     ReDim arrType(1 To UBound(arrData), 1 To 2)
     
125.     lngID = 0
     
126.    
     
127.     For lngRow = LBound(arrData) To UBound(arrData)
     
128.         If Trim(arrData(lngRow, 1)) Like strType & "*" Then
     
129.             lngID = lngID + 1
     
130.             arrType(lngID, 1) = arrData(lngRow, 2)
     
131.             arrType(lngID, 2) = arrData(lngRow, 3)
     
132.             strKey = Trim(arrData(lngRow, 3))
     
133.             objDIc(strKey) = ""
     
134.         End If
     
135.     Next
     
136.    
     
137.     If lngCount > objDIc.Count Then
     
138.         MsgBox "【" & strType & "】型题可抽题目不足！"
     
139.         GetProblemsByOneType = False
     
140.         Exit Function
     
141.     End If
     
142.    
     
143.     ReDim arrProblens(1 To lngCount, 1 To 1)
     
144.     ReDim arrAnswer(1 To lngCount, 1 To 1)
     
145.     objDIc.RemoveAll
     
146.    
     
147.     Do Until objDIc.Count = lngCount
     
148.         lngRND = Int(Rnd * lngID + 1)
     
149.         strKey = arrType(lngRND, 2)
     
150.         objDIc(strKey) = arrType(lngRND, 1)
     
151.     Loop
     
152.    
     
153.     arrKeys = objDIc.keys
     
154.     arrItems = objDIc.items
     
155.    
     
156.     Set objDIc = Nothing
     
157.    
     
158.     For lngID = LBound(arrKeys) To UBound(arrKeys)
     
159.         arrProblens(lngID + 1, 1) = arrItems(lngID)
     
160.         arrAnswer(lngID + 1, 1) = arrKeys(lngID)
     
161.     Next
     
162.     GetProblemsByOneType = True
     
163. End Function
     

复制代码

lsdongjh

给你做成模块化，代码审核中，见附件哦
母版题库.rar (100.79 KB, 下载次数: 9)

2019-8-2 14:18 上传

点击文件名下载附件

zjjEH

一把小刀闯天下 发表于 2019-8-1 16:04
A就这么一点点数据？如果条件确定，，，

请前辈指教！不甚感谢！