按百分比提取题库各类型题存至令一工作簿，求教

丁是丁

学习制作VBA窗体，过程中对题库科目类型和题型进行随机抽选遇到疑问，请各位老师指点下，新年之前谢谢各位老师了。

现在有题库存放再sheet5中，题库分为判断题，单选题和多选题三部分。

题库抽题.zip (108.18 KB, 下载次数: 0)

2024-2-3 08:54 上传

点击文件名下载附件

  VBA存放在模块1中。


按frm_D6kaoshishuliang窗体中考试科目和数量，对应题库中随机抽取40%的判断题，40%的单选题和20%的多选题，然后将随机抽取的试题存放到sheet4模拟考试组题中存储。


同时根据窗体中出题的总数，再答题窗体frm_D6kaoshi中对应的答题卡内显示出对应数量的控件。后期准备利用控件来快速看对应序号的试题。
'请老师帮助，谢谢了。希望带个注解。。。。。






Sub 出题()
'按frm_D6kaoshishuliang窗体中考试科目和数量，对应题库中随机抽取40%的判断题，40%的单选题和20%的多选题，然后将随机抽取的试题存放到sheet4模拟考试组题中存储。
'比如目前是煤矿瓦斯抽采作业，试题数量为50，那就从对应题库中按比例抽取判断题，单选题和多选题，存放到sheet4中，；

'再组题页面，我的答案存放再最后一列，答案为frm_D6kaoshi再答题过程中对应题号确定的我的答案。

'第二步：同时根据窗体中出题的总数，再答题窗体frm_D6kaoshi中对应的答题卡内显示出对应数量的控件。后期准备利用控件来快速看对应序号的试题。
'请老师帮助，谢谢了。希望带个注解。。。。。



    Dim arr, arr_choosed(), sarr(), arr_choosed2(), arr_choosed3()
    Dim St_num As Long, i As Long, St_Type As String   '定义题目数量和试题类型
   
    Dim n As Long, dic As Object, j As Long
    Dim M As Long '定义变量
    Dim L As Long
   
    Dim Z As Long
    Dim dic2 As Object
    Dim dic3 As Object
   
   
    If frm_Cmulu.Caption = "煤矿瓦斯抽采作业----模拟考试目录" Then   '此处判断条件为后期新增加题库改动增加部分
        arr = Sheet5.Range("a2", "s" & Sheet5.Range("a" & Rows.Count).End(xlUp).Row)
   
   
    St_num = frm_D6kaoshishuliang.ComboBox2.Value '数量=考试数量窗体的值
    'numQuestion = St_num
   
    St_Type = frm_D6kaoshishuliang.Label2.Caption  '试题类型
   
   
    Sheet4.Range("g6") = "正在答题" '设置答题状态
    Sheet4.Range("g2") = frm_A1denglu.TextBox1.Value  '用户名取的是登录窗体用户名
    Sheet5.Range("g4") = Format(Now, "yyyy/m/d hh:mm")
   
    For i = 1 To UBound(arr)
        If arr(i, 13) = St_Type And arr(i, 3) = "判断题" Then
            n = n + 1
            ReDim Preserve arr_choosed(1 To n)
            arr_choosed(n) = arr(i, 1)
        End If
    Next
   
    For i = 1 To UBound(arr)
        If arr(i, 13) = St_Type And arr(i, 3) = "单选题" Then
            M = M + 1
            ReDim Preserve arr_choosed2(1 To M)
            arr_choosed2(M) = arr(i, 1)
        End If
    Next
   
     For i = 1 To UBound(arr)
       If arr(i, 10) = St_Type And arr(i, 3) = "多选题" Then
           L = L + 1
            ReDim Preserve arr_choosed3(1 To L)
           arr_choosed3(L) = arr(i, 1)
        End If
    Next
   
   
   
    '判断题目数量是否足够
    If n < St_num * 0.4 Then
        MsgBox "题库中没有足够判断题目！"
        Exit Sub
    End If
   
    If M < St_num * 0.4 Then
        MsgBox "题库中没有足够单选题目！"
        Exit Sub
    End If
   
    If L < St_num * 0.2 Then
        MsgBox "题库中没有足够多选题目！"
        Exit Sub
    End If
   
   
    '随机出题
    Set dic = CreateObject("scripting.dictionary")
    Do
        
        dic(arr_choosed(Application.RandBetween(1, n))) = ""
        
        
    Loop Until dic.Count = St_num * 0.4
   
   
    Set dic2 = CreateObject("scripting.dictionary")
    Do
        
        dic2(arr_choosed2(Application.RandBetween(1, M))) = ""
        
        
    Loop Until dic2.Count = St_num * 0.4
   
   
   
    Set dic3 = CreateObject("scripting.dictionary")
    Do
        
        dic3(arr_choosed3(Application.RandBetween(1, L))) = ""
        
        
    Loop Until dic3.Count = St_num * 0.2
   
   
   
    ReDim sarr(1 To St_num, 1 To 3)
   
    For j = 0 To dic.Count - 1
        Z = Z + 1
        sarr(Z, 1) = Z
        sarr(Z, 2) = dic.keys()(j)
        sarr(Z, 3) = arr(dic.keys()(j), 12)
    Next
   
    For j = 0 To dic2.Count - 1
        Z = Z + 1
        sarr(Z, 1) = Z
        sarr(Z, 2) = dic2.keys()(j)
        sarr(Z, 3) = arr(dic2.keys()(j), 12)
    Next
   
   
    For j = 0 To dic3.Count - 1
        Z = Z + 1
        sarr(Z, 1) = Z
        sarr(Z, 2) = dic3.keys()(j)
        sarr(Z, 3) = arr(dic3.keys()(j), 12)
    Next
   
    Unload frm_D6kaoshishuliang
    Sheet4.Range("a2", "f" & Sheet4.Range("a" & Rows.Count).End(xlUp).Row).ClearContents
    Sheet4.Range("a2").Resize(St_num, 3) = sarr
    frm_D6kaoshi.Show
    MsgBox "试题已生成完毕，请考试开始答题！"
   
    End If
   
End Sub

请老师们帮忙看看。。。。。谢谢了提前祝福大家新年快乐。。。。

丁是丁

需要做全局变量吗？

张劲松2024

不错的思路！！！！！！！！！！！！！！！！！！！！！！！！！！！！！！