[已解决]求大神帮忙

196391689

在SHEET1设置两个按钮
点击第一个按钮显示SHEET2的27个问题中的随机10个
点击第二个按钮将SHEET1中显示的10个题目的答案显示出来

最佳答案

月排行榜 / 总排行榜

liuguansky

2013-12-10 00:01

1. Dim ArrXti$(), Arr, D As New Dictionary, Dt As New Dictionary
   
2. Sub Xti()
   
3.     Dim I&, U&, T&
   
4.     With Sheet1
   
5.         Arr = .Range("A1:a" & .Cells(.Rows.Count, 1).End(3).Row)
   
6.     End With
   
7.     For I = 1 To UBound(Arr)
   
8.         If Arr(I, 1) Like "[0-9]*" Then
   
9.             T = CLng(Left(Arr(I, 1), InStr(1, Arr(I, 1), ".")))
   
10.             If Not D.Exists(T) Then D.Add T, I
    
11.         End If
    
12.     Next I
    
13.     I = 0: ReDim ArrXti(1 To 70, 1 To 1): Dt.RemoveAll
    
14.     Do While I < 10
    
15.         U = Int(Rnd() * D.Count + 1)
    
16.         If Not Dt.Exists(U) Then
    
17.             Debug.Print D.Count
    
18.             ArrXti(I * 7 + 1, 1) = I + 1 & Mid(Arr(D(U), 1), InStr(1, Arr(D(U), 1), "."))
    
19.             I = I + 1: Dt.Add U, ""
    
20.         End If
    
21.     Loop
    
22.     Sheet2.[a1].Resize(70) = ArrXti
    
23. End Sub
    
24. Sub GetAnswer()
    
25.     Dim Ar, I&, J&, K&, U&(1)
    
26.     If Dt.Count > 0 Then
    
27.         Ar = Dt.Keys
    
28.         For I = 0 To 9
    
29.             K = 1: U(0) = IIf(Ar(I) = 1, 2, D(Ar(I)) + 1)
    
30.             If Ar(I) = D.Count Then
    
31.                 U(1) = UBound(Arr)
    
32.             Else
    
33.                 U(1) = D(Ar(I) + 1) - 1
    
34.             End If
    
35.             For J = U(0) To U(1)
    
36.                 K = K + 1
    
37.                 ArrXti(I * 7 + K, 1) = Arr(J, 1)
    
38.             Next J
    
39.         Next I
    
40.         Sheet2.[a1].Resize(70) = ArrXti
    
41.     Else
    
42.         MsgBox "请先随机题目."
    
43.     End If
    
44. End Sub
    

复制代码

11.zip (16.37 KB, 下载次数: 13)

2013-12-10 09:26 上传

点击文件名下载附件

跳转到最佳答案楼层

liuguansky

1. Dim ArrXti$(), Arr, D As New Dictionary, Dt As New Dictionary
   
2. Sub Xti()
   
3.     Dim I&, U&, T&
   
4.     With Sheet1
   
5.         Arr = .Range("A1:a" & .Cells(.Rows.Count, 1).End(3).Row)
   
6.     End With
   
7.     For I = 1 To UBound(Arr)
   
8.         If Arr(I, 1) Like "[0-9]*" Then
   
9.             T = CLng(Left(Arr(I, 1), InStr(1, Arr(I, 1), ".")))
   
10.             If Not D.Exists(T) Then D.Add T, I
    
11.         End If
    
12.     Next I
    
13.     I = 0: ReDim ArrXti(1 To 70, 1 To 1): Dt.RemoveAll
    
14.     Do While I < 10
    
15.         U = Int(Rnd() * D.Count + 1)
    
16.         If Not Dt.Exists(U) Then
    
17.             Debug.Print D.Count
    
18.             ArrXti(I * 7 + 1, 1) = I + 1 & Mid(Arr(D(U), 1), InStr(1, Arr(D(U), 1), "."))
    
19.             I = I + 1: Dt.Add U, ""
    
20.         End If
    
21.     Loop
    
22.     Sheet2.[a1].Resize(70) = ArrXti
    
23. End Sub
    
24. Sub GetAnswer()
    
25.     Dim Ar, I&, J&, K&, U&(1)
    
26.     If Dt.Count > 0 Then
    
27.         Ar = Dt.Keys
    
28.         For I = 0 To 9
    
29.             K = 1: U(0) = IIf(Ar(I) = 1, 2, D(Ar(I)) + 1)
    
30.             If Ar(I) = D.Count Then
    
31.                 U(1) = UBound(Arr)
    
32.             Else
    
33.                 U(1) = D(Ar(I) + 1) - 1
    
34.             End If
    
35.             For J = U(0) To U(1)
    
36.                 K = K + 1
    
37.                 ArrXti(I * 7 + K, 1) = Arr(J, 1)
    
38.             Next J
    
39.         Next I
    
40.         Sheet2.[a1].Resize(70) = ArrXti
    
41.     Else
    
42.         MsgBox "请先随机题目."
    
43.     End If
    
44. End Sub
    

复制代码

11.zip (16.37 KB, 下载次数: 13)

2013-12-10 09:26 上传

点击文件名下载附件

196391689

liuguansky 发表于 2013-12-10 09:26

谢谢你太完美了，下一步设置一个按钮，将答案的DR 和 CR 部分放到旁边表的相应位置,如果一个科目有两个以上数字则做和

196391689

196391689 发表于 2013-12-10 12:21
谢谢你太完美了，下一步设置一个按钮，将答案的DR 和 CR 部分放到旁边表的相应位置,如果一个科目有两个以 ...

这个是最后一步了谢谢你，