求大神给解答10*10矩阵

一把小刀闯天下

tc8217815 发表于 2018-7-12 22:07
对！就是这个意思！有速度快点的嘛。我试了好些次，有时候会卡
谢谢！

'修改了一下，10*10速度非常快，20就开始卡了

Option Explicit

Sub test()
  Dim i, j, k, a, n, t, key, b, s, dt
  dt = Timer
  ReDim arr(1 To 10, 1 To 10), dic(1 To 2)
  For i = 1 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  For i = 1 To UBound(arr, 2): arr(1, i) = i: Next
  Randomize
  For i = 1 To UBound(arr, 2)
    n = Int(Rnd * UBound(arr, 1)) + 1
    t = arr(1, i): arr(1, i) = arr(1, n): arr(1, n) = t
  Next
  For j = 1 To UBound(arr, 2)
    dic(1).RemoveAll: n = 1
    For i = 1 To UBound(arr, 1)
      If i <> arr(1, j) Then dic(1)(i) = vbNullString
    Next
    For Each key In dic(1).keys
      n = n + 1: arr(n, j) = key
  Next key, j
  For j = 1 To UBound(arr, 2)
    Randomize
    For i = 2 To UBound(arr, 1)
      dic(1).RemoveAll
      For b = j - 1 To 1 Step -1
        dic(1)(arr(i, b)) = vbNullString
      Next
      For a = i - 1 To 1 Step -1
        dic(1)(arr(a, j)) = vbNullString
      Next
      dic(2).RemoveAll
      For a = 1 To 10
        If Not dic(1).exists(a) Then dic(2)(a) = vbNullString
      Next
      If dic(2).Count > 0 Then
        t = dic(2).keys
        s = Int(Rnd * (UBound(t) + 1))
        arr(i, j) = t(s)
      Else
        i = 1
      End If
  Next i, j
  [a1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  Debug.Print Timer - dt
End Sub

一把小刀闯天下

tc8217815 发表于 2018-7-12 22:07
对！就是这个意思！有速度快点的嘛。我试了好些次，有时候会卡
谢谢！

'1000*1000 <1s

Option Explicit

Const NUM  As Long = 1000  '改成10 就可以了

Sub test()
  Dim i As Long, j As Long, n As Long, t As Long, dt
  dt = Timer
  ReDim arr(1 To NUM, 1 To NUM) As Long
  For j = 1 To NUM
    n = 0
    For i = j To NUM: n = n + 1: arr(i, j) = n: Next
    n = NUM - j + 1
    For i = 1 To j - 1: n = n + 1: arr(i, j) = n: Next
  Next
  Randomize
  For i = 1 To NUM
    n = Int(Rnd * NUM) + 1
    For j = 1 To NUM
      t = arr(i, j): arr(i, j) = arr(n, j): arr(n, j) = t
  Next j, i
  For j = 1 To NUM
    n = Int(Rnd * NUM) + 1
    For i = 1 To NUM
      t = arr(i, j): arr(i, j) = arr(i, n): arr(i, n) = t
  Next i, j
  [a1].Resize(NUM, NUM) = arr
  Debug.Print dt - Timer
End Sub

香川群子

一把小刀闯天下 发表于 2018-7-17 12:48
'1000*1000

是整行或整列的随机交换，也能保证行、列总和不变。

这个算法是正确的。而且效率更高。

可以同时进行行、列的置换。

1. Sub test2() 'by kagawa 2018/07/17
   
2.     Dim a&(), i&, j&, k&, m&, n&, t&, t1&, t2&, tms#
   
3.     tms = Timer
   
4.    
   
5.     m = Range("N1") '矩阵行列数m
   
6.     n = m - 1
   
7.     ReDim a(n, n)
   
8.     For i = 0 To n
   
9.         For j = 0 To n
   
10.             a(i, j) = (i + j) Mod m + 1
    
11.         Next
    
12.     Next
    
13.    
    
14.     Randomize
    
15.     For k = 1 To 20 '随机交换 一般20轮次足够
    
16.         For t1 = 0 To n
    
17.             t2 = (t1 + 1 + Int(Rnd * n)) Mod m '不同的随机行t2
    
18.             For j = 0 To n
    
19.                 t = a(t1, j): a(t1, j) = a(t2, j): a(t2, j) = t
    
20.             Next
    
21.             t2 = (t1 + 1 + Int(Rnd * n)) Mod m '不同的随机列t2
    
22.             For i = 0 To n
    
23.                 t = a(i, t1): a(i, t1) = a(i, t2): a(i, t2) = t
    
24.             Next
    
25.         Next
    
26.     Next
    
27.    
    
28.     Range("P1").CurrentRegion.Clear
    
29.     Range("P1").Resize(m, m) = a
    
30.     Range("P1").Resize(m, m).Borders.LineStyle = 1
    
31.     MsgBox Format(Timer - tms, "0.000s")
    
32. End Sub

复制代码