生成满足一定条件的1-20的不重复的整数

dsmch

1. Dim arr, brr, crr(1 To 13, 1 To 1), d As Object, dic As Object
   
2. Dim w, x1%, x%, i&
   
3. arr = [d2:d14]
   
4. brr = [i2:i14]
   
5. w = Array(5, 8, 13)
   
6. x1 = Int(Rnd * 3)
   
7. crr(w(x1), 1) = brr(13, 1)
   
8. line2:
   
9. Set d = CreateObject("scripting.dictionary")
   
10. Set dic = CreateObject("scripting.dictionary")
    
11. For i = 1 To 13
    
12. line1:
    
13.     x = Int(Rnd * 12 + 1)
    
14.     If i = w(x1) Then GoTo line3
    
15.     If Not d.exists(arr(i, 1) & "," & brr(x, 1)) Then d(arr(i, 1) & "," & brr(x, 1)) = "":  crr(i, 1) = brr(x, 1): dic(x) = "" Else GoTo line1
    
16. line3:
    
17. Next
    
18. If d.Count < 12 Then
    
19.     GoTo line2
    
20. Else
    
21.     If dic.Count < 12 Then GoTo line2 Else Range("b2").Resize(UBound(crr), 1) = crr
    
22. End If
    

复制代码

这样？

拾音2012

dsmch 发表于 2012-11-17 16:39
这样也不能满足要求啊。

此代码成功解决了我的问题，给我的帮助太大了，非常感谢。

拾音2012

dsmch 发表于 2012-11-17 17:49
这样？

此篇也能解决问题，但有时运行时间太长。真的很强。您太费心了。

拾音2012

拾音2012 发表于 2012-11-17 21:15
此篇也能解决问题，但有时运行时间太长。真的很强。您太费心了。

我没说得很清楚，你理解得很正确。本来是第1、2节不上体育课，但因两节连上，所以就是第一节。
您给我提供的答案已经能帮我解决问题了，而我觉得您不仅水平高，而且很热心，所以我还有一个更深的问题想请你帮我解答。
不用函数而是在一个宏按钮上添加代码，在A1:A13生成1-13不重复的随机整数，在B1:B13也一样，……直到CB1:CB13，共80列。如果太繁琐了的话，您就不要费心了。

dsmch

1. Dim arr(1 To 13, 1 To 80), d1 As Object, d As Object
   
2. Dim i%, j%, x%
   
3. Range("a1:cb13").ClearContents
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For j = 1 To UBound(arr, 2)
   
6. line2:
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     For i = 1 To 13
   
9. line1:
   
10.         x = Int(Rnd * 13 + 1)
    
11.         If Not d1.exists(x) Then d1(x) = "" Else GoTo line1
    
12.     Next
    
13.         If Not d.exists(Join(d1.keys, ",")) Then
    
14.             Cells(1, j).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    
15.         Else: GoTo line2
    
16.         End If
    
17. Next
    

复制代码

拾音2012

dsmch 发表于 2012-11-18 09:30

非常感谢，您实在太高了。