随机数字

350977106

  用vba代码如何实现，在A1：D15列区域内，实现1到15个数字在每列随机排列，并且每行也没有重复数字，数字之间不能连锁，即完全随机。如A列有4，9，5，3的连续单元格，在其它列就不能再出现4，9或9，5等的连续单元格。

excel海

能解决大部分问题

1. Function sj(arr)
   
2.     Dim i, d, t
   
3.     For i = 1 To 15
   
4.         d = Int(Rnd * 15 + 1)
   
5.         t = arr(i, 1)
   
6.         arr(i, 1) = arr(d, 1)
   
7.         arr(d, 1) = t
   
8.     Next
   
9.     sj = arr
   
10. End Function
    
11. Sub test()
    
12.   Dim i, d, t
    
13.     ReDim arr(1 To 15, 1 To 1)
    
14.     For i = 1 To 15
    
15.         arr(i, 1) = i
    
16.     Next
    
17.     For i = 1 To 4
    
18.         arr = sj(arr)
    
19.         Cells(1, i).Resize(15) = arr
    
20.     Next
    
21. End Sub
    

复制代码

liulang0808

1. Sub 按钮1_Click()
   
2.     Dim arr(1 To 15, 1 To 3)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set dr = CreateObject("scripting.dictionary")
   
5.     Set dc = CreateObject("scripting.dictionary")
   
6. l2:
   
7.     w = 0
   
8.     d.RemoveAll
   
9.     dr.RemoveAll
   
10.     dc.RemoveAll
    
11.     For i = 1 To 3
    
12.         d.RemoveAll
    
13.         For j = 1 To 15
    
14.             d(j) = j
    
15.         Next j
    
16.         For j = 1 To UBound(arr)
    
17. l1:
    
18.             If w > 1000 Then GoTo l2
    
19.             x = WorksheetFunction.RandBetween(0, d.Count - 1)
    
20.             n = d.keys()(x)
    
21.             If Not dr.exists(j & "#" & n) Then
    
22.                 If j > 1 Then
    
23.                     str1 = arr(j - 1, i) & "#" & n
    
24.                     If Not dc.exists(str1) Then
    
25.                         dc(str1) = ""
    
26.                         dr(j & "#" & n) = ""
    
27.                         d.Remove n
    
28.                         arr(j, i) = n
    
29.                     Else
    
30.                         w = w + 1
    
31.                         GoTo l1
    
32.                     End If
    
33.                 Else
    
34.                     dr(j & "#" & n) = ""
    
35.                     d.Remove n
    
36.                     arr(j, i) = n
    
37.                 End If
    
38.             Else
    
39.                 w = w + 1
    
40.                 GoTo l1
    
41.             End If
    
42.         Next j
    
43.     Next i
    
44.     [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
45. End Sub

复制代码

liulang0808

附件内容供参考。。。。

350977106

谢谢两位老师的答复，经测试，程序运行较快，不卡机，运用了字典方法，正是我想学的，但结果同行有重复数字，不太符合要求。能不能帮忙完善一下。
我原来编制过一个，没用字典方法，运行非常卡，连续几次就得重启excel,但能达到我要求，或者在我的思路上,给改进一下。
我的代码如下：垦请不吝赐教！！！
Sub 小区设计()
  m = Range("b1") 'b1为重复数，3或4
    n = Range("b2") 'b2为小区数，一般4-16之间
   

Range("3:" & Rows.Count).Clear
   Range("c3:f18").Font.Size = 14
        For i = 1 To n
iii:
         Randomize
        x = Int(Rnd * n) + 1
      
        If Application.CountIf(Range("C:C"), x) = 0 Then
        Cells(i + 2, 3) = x
        Else
GoTo iii
        End If
        Next i
        
        For j = 1 To n
jjj:
         Randomize
        y = Int(Rnd * n) + 1
        
        If Application.CountIf(Range("D:D"), y) = 0 And Application.CountIf(Rows(j + 2), y) = 0 Then
        Cells(j + 2, 4) = y
        Else
GoTo jjj
      
        End If
        Next j
      
      For k = 1 To n
kkk:
         Randomize
        Z = Int(Rnd * n) + 1
      
        If Application.CountIf(Range("E:E"), Z) = 0 And Application.CountIf(Rows(k + 2), Z) = 0 Then
        Cells(k + 2, 5) = Z
        Else
GoTo kkk
      
        End If
     
        Next k
           
      
    If m = 4 Then
       For q = 1 To n
qqq:
         Randomize
        p = Int(Rnd * n) + 1
      
        If Application.CountIf(Range("F:F"), p) = 0 And Application.CountIf(Rows(q + 2), p) = 0 Then
        Cells(q + 2, 6) = p
        Else
GoTo qqq
      
        End If
     
        Next q
      
    End If
  
End Sub

yjh_27

350977106 发表于 2020-2-21 20:04
谢谢两位老师的答复，经测试，程序运行较快，不卡机，运用了字典方法，正是我想学的，但结果同行有重复数字 ...

参见附件。

350977106

yjh_27 发表于 2020-2-22 14:48
参见附件。

谢谢老师的回答，完美解决了我的问题，里面有详细的讲解，说明，下来一定用心学习。

350977106

雷同字符提取函数 自定义函数
http://club.excelhome.net/thread-883745-1-1.html
(出处: ExcelHome技术论坛)
链接已被我收藏，慢慢学习，崇拜

SCL5801

学习了额。

350977106

excel海 发表于 2020-2-21 19:06
能解决大部分问题

加入行判断语句，用单重复生成随机数，能达到要求，用大循环，就出错。是哪儿了出错了呢。


Sub test()

Dim i, d, t
ReDim arr(1 To 15, 1 To 1)
For i = 1 To 15
arr(i, 1) = i
Next

For i = 1 To 4
For k = 1 To 15
x: arr = sj(arr)
Cells(1, i).Resize(15) = arr
If Application.CountIf(Cells(Cells(k, 1), Cells(k, i)), Cells(k, i)) > 1 Then GoTo x
Next k
Next i

End Sub