[已解决]怎么能随机产生出错误率不低于80%的随机答案？

三羧酸

大家好，附件有100个选择题答案，怎么能随机产生出错误率不低于80%的随机答案？

最佳答案

月排行榜 / 总排行榜

xdragon

2013-11-8 14:20

1. Sub t()
   
2. Dim arr(), i As Byte, rnds As Byte, k As Byte, str As String
   
3. arr = Sheets("sheet1").Range("A1").Resize(2, 100).Value
   
4. rnds = Int(20 * Rnd + 1) '设置随机错误的题数
   
5. For i = 1 To rnds
   
6.   k = Int(100 * Rnd + 1)
   
7.   If InStr(1, str, k) > 0 Then
   
8.     i = i - 1
   
9.   Else
   
10.     arr(2, k) = Mid(Replace("ABCD", arr(2, k), ""), Int(3 * Rnd + 1), 1) '设置随机错误答案
    
11.   End If
    
12.   str = "," & k & "," & str
    
13. Next
    
14. Range("A4:CV5") = arr '这里是导出的区域，可以随意选哈
    
15. End Sub

复制代码

跳转到最佳答案楼层

那么的帅

用VBA 可以解决，
不低于80%，不高于多少？

三羧酸

不高于100%

三羧酸

请2楼的费心给解决一下！谢谢！

CheryBTL

三羧酸 发表于 2013-11-8 14:14
请2楼的费心给解决一下！谢谢！

随机到80%以上正确率的各分数之间，有没有概率要求？比如各个正确率的概率相等还是不管呢？？

xdragon

1. Sub t()
   
2. Dim arr(), i As Byte, rnds As Byte, k As Byte, str As String
   
3. arr = Sheets("sheet1").Range("A1").Resize(2, 100).Value
   
4. rnds = Int(20 * Rnd + 1) '设置随机错误的题数
   
5. For i = 1 To rnds
   
6.   k = Int(100 * Rnd + 1)
   
7.   If InStr(1, str, k) > 0 Then
   
8.     i = i - 1
   
9.   Else
   
10.     arr(2, k) = Mid(Replace("ABCD", arr(2, k), ""), Int(3 * Rnd + 1), 1) '设置随机错误答案
    
11.   End If
    
12.   str = "," & k & "," & str
    
13. Next
    
14. Range("A4:CV5") = arr '这里是导出的区域，可以随意选哈
    
15. End Sub

复制代码

那么的帅

数据显示在4 5 2行，
A7 公式是为了显示正确答案个数

312974-VBA-不重复随机数.rar (10.04 KB, 下载次数: 8)

2013-11-8 14:21 上传

点击文件名下载附件

三羧酸

谢谢2楼的朋友，可能我没说清楚，这个VBA产生的空白处应随机产生出一个随机错误答案！不能留出空白！请帮忙再修改一下!

CheryBTL

我的办法：

1. Sub 成绩()
   
2.     Dim ar, re(1 To 1, 1 To 100), arr
   
3.     Dim count As Integer
   
4.     ar = Sheets(1).Range("A1").CurrentRegion
   
5.     t = Rnd() * 0.2
   
6.     arr = Array("A", "B", "C", "D")
   
7.     Do Until count > 80
   
8.         For i = 1 To UBound(ar, 2)
   
9.             temp = Rnd()
   
10.             If temp > 0.2 - t Then
    
11.                 count = count + 1
    
12.                 re(1, i) = ar(2, i)
    
13.             Else
    
14.                 Do
    
15.                     re(1, i) = arr(Int(Rnd() * 4))
    
16.                 Loop Until re(1, i) <> ar(2, i)
    
17.             End If
    
18.         Next i
    
19.     Loop
    
20.     Sheets(1).Range("A10").Resize(1, 100) = re
    
21. End Sub
    

复制代码

三羧酸

问题又来了，楼上的各位朋友帮助的是生成一行随机产生出错误率不低于80%的随机答案，现在，我想要多行，比如10行不同的答案，请问有办法吗？我把VBA改了半天，可是不会弄，大家给看看吧！