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

suxiong22

麻烦各位。


要求：
1、随机抽取B列“题库名称”为：“A”的整行数据到分表；要求抽取 20题；
2、抽取比例要求：单选（A列） 60%，多选40%；
3、速度尽量快些；

感谢.




随机抽取.zip (16.74 KB, 下载次数: 57)

2018-9-24 20:44 上传

点击文件名下载附件

liulang0808

楼主是搞通信的啊
可以考虑使用字典进行去重处理的

suxiong22

liulang0808 发表于 2018-9-24 21:11
楼主是搞通信的啊
可以考虑使用字典进行去重处理的

正是搞通信的哈，哈哈；

主要是随机提取，我就不会了。

小花鹿

用字典分别记录单选和多选的题号，再随机抽取。
其实，不用字典也可以

suxiong22

小花鹿 发表于 2018-9-24 21:39
用字典分别记录单选和多选的题号，再随机抽取。
其实，不用字典也可以

帮写下呢，可以不,谢谢

不知道为什么

如图，是这个意思？

不知道为什么

审核中，先图片看看把
代码有点啰嗦了，供参考

719404338

1. Sub t()
   
2. Dim arr(1 To 26, 1 To 16), brr(1 To 23, 1 To 16), i%, x%, y%, d, k
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4.   x = 1: y = 1
   
5. For i = 2 To [a65536].End(3).Row
   
6. 
   
7. If Range("b" & i) = "A" Then
   
8.     If Range("a" & i) = "多选" Then
   
9.        arr(x, 1) = Range("a" & i)
   
10.        arr(x, 2) = Range("b" & i)
    
11.        arr(x, 3) = Range("c" & i)
    
12.        arr(x, 4) = Range("d" & i)
    
13.        arr(x, 5) = Range("e" & i)
    
14.        arr(x, 6) = Range("f" & i)
    
15.        arr(x, 7) = Range("g" & i)
    
16.        arr(x, 8) = Range("h" & i)
    
17.        arr(x, 9) = Range("i" & i)
    
18.        arr(x, 10) = Range("j" & i)
    
19.        arr(x, 11) = Range("k" & i)
    
20.        arr(x, 12) = Range("l" & i)
    
21.        arr(x, 13) = Range("m" & i)
    
22.        arr(x, 14) = Range("o" & i)
    
23.        arr(x, 15) = Range("p" & i)
    
24.        arr(x, 16) = Range("q" & i)
    
25.            x = x + 1
    
26.      Else
    
27.        brr(y, 1) = Range("a" & i)
    
28.        brr(y, 2) = Range("b" & i)
    
29.        brr(y, 3) = Range("c" & i)
    
30.        brr(y, 4) = Range("d" & i)
    
31.        brr(y, 5) = Range("e" & i)
    
32.        brr(y, 6) = Range("f" & i)
    
33.        brr(y, 7) = Range("g" & i)
    
34.        brr(y, 8) = Range("h" & i)
    
35.        brr(y, 9) = Range("i" & i)
    
36.        brr(y, 10) = Range("j" & i)
    
37.        brr(y, 11) = Range("k" & i)
    
38.        brr(y, 12) = Range("l" & i)
    
39.        brr(y, 13) = Range("m" & i)
    
40.        brr(y, 14) = Range("o" & i)
    
41.    
    
42.            y = y + 1
    
43.       End If
    
44.    End If
    
45.    Next
    
46.    Stop
    
47.    For i = 1 To 26
    
48.     d(WorksheetFunction.RandBetween(1, 26)) = ""
    
49.    Next
    
50.    s = d.keys
    
51.   Stop
    
52.      Sheet2.Select
    
53.   For i = 2 To 13
    
54.       Sheet2.Range("a" & i) = arr(s(i - 2), 1)
    
55.       Sheet2.Range("b" & i) = arr(s(i - 2), 2)
    
56.       Sheet2.Range("c" & i) = arr(s(i - 2), 3)
    
57.       Sheet2.Range("d" & i) = arr(s(i - 2), 4)
    
58.       Sheet2.Range("e" & i) = arr(s(i - 2), 5)
    
59.       Sheet2.Range("f" & i) = arr(s(i - 2), 6)
    
60.       Sheet2.Range("g" & i) = arr(s(i - 2), 7)
    
61.       Sheet2.Range("h" & i) = arr(s(i - 2), 8)
    
62.       Sheet2.Range("i" & i) = arr(s(i - 2), 9)
    
63.       Sheet2.Range("j" & i) = arr(s(i - 2), 10)
    
64.       Sheet2.Range("k" & i) = arr(s(i - 2), 11)
    
65.       Sheet2.Range("l" & i) = arr(s(i - 2), 12)
    
66.       Sheet2.Range("m" & i) = arr(s(i - 2), 13)
    
67.       Sheet2.Range("n" & i) = arr(s(i - 2), 14)
    
68.       Sheet2.Range("o" & i) = arr(s(i - 2), 15)
    
69.       Sheet2.Range("p" & i) = arr(s(i - 2), 16)
    
70.        Next
    
71.        Stop
    
72.    d.RemoveAll
    
73.   For i = 1 To 23
    
74.     d(WorksheetFunction.RandBetween(1, 23)) = ""
    
75.    Next
    
76.    s = d.keys
    
77.   For i = 14 To 21
    
78.       Sheet2.Range("a" & i) = brr(s(i - 14), 1)
    
79.       Sheet2.Range("b" & i) = brr(s(i - 14), 2)
    
80.       Sheet2.Range("c" & i) = brr(s(i - 14), 3)
    
81.       Sheet2.Range("d" & i) = brr(s(i - 14), 4)
    
82.       Sheet2.Range("e" & i) = brr(s(i - 14), 5)
    
83.       Sheet2.Range("f" & i) = brr(s(i - 14), 6)
    
84.       Sheet2.Range("g" & i) = brr(s(i - 14), 7)
    
85.       Sheet2.Range("h" & i) = brr(s(i - 14), 8)
    
86.       Sheet2.Range("i" & i) = brr(s(i - 14), 9)
    
87.       Sheet2.Range("j" & i) = brr(s(i - 14), 10)
    
88.       Sheet2.Range("k" & i) = brr(s(i - 14), 11)
    
89.       Sheet2.Range("l" & i) = brr(s(i - 14), 12)
    
90.       Sheet2.Range("m" & i) = brr(s(i - 14), 13)
    
91.       Sheet2.Range("n" & i) = brr(s(i - 14), 14)
    
92.       Sheet2.Range("o" & i) = brr(s(i - 14), 15)
    
93.       Sheet2.Range("p" & i) = brr(s(i - 14), 16)
    
94.        Next
    
95. End Sub
    

复制代码

liulang0808

1. Sub aaa()
   
2.     t = 20
   
3.     Dim rng As Range
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     Sheets("分表").UsedRange.Offset(1).ClearContents
   
8.     arr = Sheets("总表").UsedRange
   
9.     With Sheets("总表")
   
10.         For j = 2 To UBound(arr)
    
11.             If arr(j, 1) = "多选" Then
    
12.                 d1(j) = j
    
13.             Else
    
14.                 If arr(j, 1) = "单选" Then
    
15.                     d2(j) = j
    
16.                 End If
    
17.             End If
    
18.         Next j
    
19.         Set rng = Nothing
    
20.         For j = 1 To t * 0.6
    
21.             x = d2.keys()(WorksheetFunction.RandBetween(0, d2.Count - 1))
    
22.             If rng Is Nothing Then
    
23.                 Set rng = .Cells(x, 1)
    
24.             Else
    
25.                 Set rng = Union(rng, .Cells(x, 1))
    
26.             End If
    
27.             d2.Remove x
    
28.         Next j
    
29.         rng.EntireRow.Copy Sheets("分表").Cells(Rows.Count, 1).End(3).Offset(1)
    
30.         Set rng = Nothing
    
31.         For j = 1 To t * 0.4
    
32.             x = d1.keys()(WorksheetFunction.RandBetween(0, d1.Count - 1))
    
33.             If rng Is Nothing Then
    
34.                 Set rng = .Cells(x, 1)
    
35.             Else
    
36.                 Set rng = Union(rng, .Cells(x, 1))
    
37.             End If
    
38.             d1.Remove x
    
39.         Next j
    
40.         rng.EntireRow.Copy Sheets("分表").Cells(Rows.Count, 1).End(3).Offset(1)
    
41.     End With
    
42. 
    
43.     Application.ScreenUpdating = True
    
44. End Sub
    

复制代码

liulang0808

楼主这是要参加什么竞赛吗？
不过感觉楼主题库的答案看着有些别扭呢