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

chxw68

代码有问题删除。

zjjEH

非常强大，万分感谢！真是无从言表！

zjjEH

chxw68  真心向大神学习，现正在测试，如有疑问望不厌赐教！

chxw68

zjjEH 发表于 2019-8-1 17:46
chxw68  真心向大神学习，现正在测试，如有疑问望不厌赐教！

你觉得这么直呼其名辛苦帮助你的人好吗？大街上问个路还要尊称人家一声“师傅”呢。

maditate

zjjEH 发表于 2019-8-1 17:46
chxw68  真心向大神学习，现正在测试，如有疑问望不厌赐教！

'以当前工作表为准。活动工作表 D ，则出 D 类试卷。运行此代码按钮自已想法添加。
'题库各类题目可以任意打乱，A中可穿插B类，C类中可穿插E类，不限顺序。




母版题库.rar (100.04 KB, 下载次数: 8)

2019-8-1 17:57 上传

点击文件名下载附件

zjjEH

chxw68 发表于 2019-8-1 17:51
你觉得这么直呼其名辛苦帮助你的人好吗？大街上问个路还要尊称人家一声“师傅”呢。

您早已是我这只菜鸟的师傅了！我也是为了学生，但这方面又太薄弱，谢谢了！

zjjEH

maditate 发表于 2019-8-1 17:58
'以当前工作表为准。活动工作表 D ，则出 D 类试卷。运行此代码按钮自已想法添加。
'题库各类题目可以任 ...

谢谢师傅，很实用，但有一个想法，出C级试卷时可不可以从C类内抽30题，从B类内抽8题，从A类内抽2题，都是随机的。

zjjEH

谢谢师傅，很实用，但有一个想法，出C级试卷时可不可以从C类内抽30题，从B类内抽8题，从A类内抽2题，都是随机的，类推。A级以上各级出卷时在下面各级抽题数是输入的。

gbgbxgb

较好的求助附件，往往能得到他人的细心写码。

估计附件中代码才是你真正想要的。

原本自认为附件代码合乎楼主意思，岂料其吭都不吭一声，让人大跌眼镜。
套用他人一句：不献丑了。
附件赶紧删除。

一把小刀闯天下

'a:c20,h8,b10,a2   -->输出A工作表，20个C类题，8个H类题，，，合计必须为40

Option Explicit

Sub test()
  Dim data, dic(1), i, j, p, sht, s, t, m, n, cnt, a, b, mark
  mark = Split("a:c20,h8,b10,a2|b:f10,g8,c10,b10,a2|c:c30,b8,a2", "|") '可以生成多套题
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  data = Sheets("题库").[a1].CurrentRegion.Offset(1).Resize(, 2)
  For i = 1 To UBound(data, 1) - 1
    If Left(data(i, 1), 1) <> Left(data(i + 1, 1), 1) Then
      dic(0)(Left(data(i, 1), 1)) = Array(p + 1, i)
      p = i
    End If
  Next
  Randomize
  For i = 0 To UBound(mark)
    mark(i) = UCase(mark(i))
    t = Split(mark(i), ":")
    sht = t(0)
    If Not dic(0).exists(sht) Then MsgBox sht: Exit Sub
    t = Split(t(1), ",")
    b = 5: dic(1).RemoveAll: m = 0
    ReDim arr(1 To 20, 1 To 1) As String
    For j = 0 To UBound(t)
      s = Left(t(j), 1)
      If Not dic(0).exists(s) Then MsgBox s: Exit Sub
      n = Val(Mid(t(j), 2))
      p = dic(0)(s): cnt = p(1) - p(0) + 1
      Do
        a = Int(Rnd * cnt) + p(0)
        If Not dic(1).exists(data(a, 1)) Then
          m = m + 1: n = n - 1: dic(1)(data(a, 1)) = n
          arr(m, 1) = data(a, 1) & data(a, 2)
          If m Mod 20 = 0 Then
            Sheets(sht).Cells(5, b).Resize(UBound(arr, 1)) = arr
            ReDim arr(1 To 20, 1 To 1) As String
            b = b + 4: m = 0
          End If
        End If
        DoEvents
      Loop Until n = 0
    Next
  Next
End Sub