求按比例随机抽取数据方法

zopey

题库“A” ：
1、单选题23道，从中随机抽12道单选题； （12/20=60%）
2、多选题26道，从中随机抽8道多选题。（8/20=40%）

suxiong22

zopey 发表于 2018-9-25 09:46
题库“A” ：
1、单选题23道，从中随机抽12道单选题； （12/20=60%）
2、多选题26道，从中随机抽8道多选 ...

怎么才能做到   随机  呢

zopey

suxiong22 发表于 2018-9-25 09:49
怎么才能做到   随机  呢

vba 随机 函数 rnd（），生成数 在  0-1 之间。
可以 先生成 23个 随机数（赋值表 数组 ）  ，再 按大小 排序 ，取前 12位 。

zopey

题库 “总表” 临时增加一列 随机数辅助 列，再构造sql语句 可以直接生成 “分表”

suxiong22

zopey 发表于 2018-9-25 10:03
题库 “总表” 临时增加一列 随机数辅助 列，再构造sql语句 可以直接生成 “分表”

sql语句   查询怎么写呢

suxiong22

liulang0808 发表于 2018-9-25 07:36
楼主这是要参加什么竞赛吗？
不过感觉楼主题库的答案看着有些别扭呢

题库，B与C的也抽取了。 可否加个条件，只要A的呢。代码，我在研究下。谢谢

suxiong22

liulang0808 发表于 2018-9-25 07:36
楼主这是要参加什么竞赛吗？
不过感觉楼主题库的答案看着有些别扭呢

可以了，我加了，谢谢。

suxiong22

谢谢大家！谢谢大家那么热情，EXCELhome太好了。

zopey

suxiong22 发表于 2018-9-25 10:07
sql语句   查询怎么写呢

Sub 按钮6_Click()
Rows("2:65535").ClearContents
With Worksheets("总表")
k0 = .[a1].End(4).Row - 1
For i = 1 To k0
   .Cells(i + 1, 17) = Rnd()
Next
End With
Set cnn = CreateObject("adodb.connection")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
sql1 = "select  top 12 * from [总表$] where 题库名称='A' and 类型='单选' order by 类型,随机数"
sql2 = "select  top 8 * from [总表$] where 题库名称='A' and 类型='多选' order by 类型,随机数"
Sql = sql1 & " union " & sql2
Set rst = cnn.Execute(Sql)
[a2].CopyFromRecordset rst
cnn.Close
Set cnn = Nothing

End Sub


随机抽取2.zip (29.23 KB, 下载次数: 8)

2018-9-25 10:54 上传

点击文件名下载附件

grf1973

1. Sub 随机抽取()
   
2.     arr = Sheets(1).Range("a2:p" & Sheets(1).[a65536].End(3).Row)
   
3.     all = UBound(arr)  '所有记录数
   
4.     ReDim brr(1 To all)    '已抽取过的记录
   
5.     Total = 20   '要抽取的总条数
   
6.     ReDim crr(1 To Total, 1 To UBound(arr, 2))
   
7.     t1 = Int(Total * 0.6): t2 = Total - t1   '单选数、多选数
   
8.     Do While n < Total
   
9. qc:     p = Int(all * Rnd + 1)    '抽取
   
10.         If brr(p) = 1 Then GoTo qc   '如果已抽取过，重新抽取
    
11.         If arr(p, 1) = "单选" Then t1 = t1 - 1 Else t2 = t2 - 1
    
12.         If t1 < 0 Then t1 = 0: GoTo qc   '如果单选已抽满，且又抽到单选，重新抽取
    
13.         If t2 < 0 Then t2 = 0: GoTo qc
    
14.         n = n + 1   '有效记录
    
15.         brr(p) = 1
    
16.         For j = 1 To UBound(arr, 2)
    
17.             crr(n, j) = arr(p, j)
    
18.         Next
    
19.     Loop
    
20.     With Sheets(2)
    
21.         .Range("a2:p1000").ClearContents
    
22.         .[a2].Resize(n, UBound(arr, 2)) = crr
    
23.     End With
    
24. End Sub
    

复制代码