[發問] 在方陣或矩陣中,以旋轉方式填入值

准提部林

在方陣或矩陣中,以旋轉方式填入值

１．設一個方陣或矩陣為5*5（須考慮可能改變為7*7,9*9...)。
２．任選一個儲存格為〔中心點〕，以此中心點依〔順時針〕方向，〔由內而外〕填入值。

需求效果１：　　　　　　　　　　需求效果２：

下載 (41.85 KB)

2015-10-24 17:12

　　　　

下載 (39.64 KB)

2015-10-24 17:12

　
尋求VBA任何解法，
個人只會〔四輪定位〕法，為避免大家有先入為主的看法，暫不提供程式碼；

希望路過大大不吝提供更多方法，
先此謝過～～
　
＝＝＝2015.10.27 補充＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
程式碼請見１４～１６樓，
以非專業自學者而言，只會用最基本的儲存格判斷，所以對初學者也應容易看懂，
而其它大大的程式碼，實為正規的解法，更有參考價值，
再度謝謝各位參與的大大們～～

附件下載：
20151027-01(旋轉矩陣).rar (13.38 KB)

下載次數: 7

2015-10-27 14:46

　

ML089

1. Option Base 1
   
2. Sub 以旋轉方式填入值()
   
3. 
   
4.     xc = 10: yc = 10 '中心位置
   
5. 
   
6.     右 = [{0, 1}]: 下 = [{1,0}]: 左 = [{0,-1}]: 上 = [{-1, 0}]
   
7.     yx = Application.Transpose(Application.Transpose(Array(右, 下, 左, 上))) '控制方向及轉向
   
8.    
   
9.     n = InputBox("輸入排列數字", , 25)
   
10.     n1 = Application.RoundUp(((n ^ 0.5) - 1) / 2, 0) + 1
    
11.     nn = n1 * 2 + 1
    
12.     Cells(yc - n1, xc - n1).Resize(nn, nn).ClearContents
    
13. 
    
14.     x = xc: y = yc
    
15.     Cells(xc, yc) = 1
    
16.     For i = 2 To n
    
17.         ds = [{0,0,0,0}]
    
18.         For j = 1 To 4 '四個方向
    
19.             If Cells(y + yx(j, 1), x + yx(j, 2)) = "" Then
    
20.                 ds(j) = ((y + yx(j, 1) - yc) ^ 2 + (x + yx(j, 2) - xc) ^ 2) * 10 + j '距離*10+方向
    
21.             Else
    
22.                 ds(j) = ""
    
23.             End If
    
24.         Next
    
25.         jj = Application.Min(ds) Mod 10 '取距離原點最短及排列最前方向
    
26.         x = x + yx(jj, 2)
    
27.         y = y + yx(jj, 1)
    
28.         Cells(y, x) = i
    
29.     Next
    
30. End Sub

複製代碼

准提部林

回復 2# ML089


就是佩服板主的數學功力！
這題是之前知識+解過的問題，覺得數學太複雜，根本想不出這個方法，只能純粹以Range方法去跑～～
謝謝板主的給力～～

ML089

回復 3# 准提部林

知識+的W大用數學及函數的功力真是無人能敵，原先一開始我也是朝這方向構想。

後來看你貼的效果圖在哪裡轉啊轉啊，突然想到既然要用VBA就有全新的構想。
從貼圖的運動模式可以整理如下
1. 每一步只有 上、下、左、右 等4種步法
2. 要圍繞中心排列，所以每一步都要選擇離中心最近的距離。

'控制方向及轉向  
yx = Application.Transpose(Application.Transpose(Array(右, 下, 左, 上))) '第一步向右，順時排列

下載 (11.78 KB)

2015-10-25 09:00

利用上式中 ... 右, 下, 左, 上 的放置順序來控制方向及轉向
第1位置控制第一步方向，可以放置 ..... 右, 下, 左, 上 .... 來改變。
第2~3位置控制順、逆排列方向。

yx = Application.Transpose(Application.Transpose(Array(下, 右, 上, 左)))  '第一步向下，逆時排列

下載 (11.9 KB)

2015-10-25 09:00

只能寫些簡單VBA，介面及語法有不足的地方歡迎大家繼續修改。

no3-taco

沒有寫得很精實，但是結果是一樣的
ps:需先點選一個足夠填滿的儲存格

1. Sub testarr()  '從這裡執行
   
2. arrX 7, 1  '7階 ,數列初始值
   
3. End Sub
   
4. 
   
5. Sub arrX(numX&, k&)
   
6. Dim cx&, cy&
   
7. arr = Array(0, 1, 0, -1, 0, 1)
   
8. If numX <> 1 Then
   
9. arrX numX - 2, k
   
10.     p = (numX - 1) / 2
    
11.     For i = 1 To 4
    
12.         For j = 0 To numX - 2
    
13.             k = k + 1
    
14.             cx = ActiveCell.Row + p * arr(i - 1) + arr(i) * j - arr(i) * (p - 1)
    
15.             cy = ActiveCell.Column + p * arr(i) + arr(i + 1) * j - arr(i + 1) * (p - 1)
    
16.             Cells(cx, cy) = k
    
17.         Next j
    
18.     Next i
    
19.     p = p + 1
    
20. Else
    
21.     ActiveCell = k
    
22. End If
    
23. End Sub

複製代碼

准提部林

回復 5# no3-taco


這是我完全不可能去想的方式, 真是 老手 + 高手,
測試完全符合,
謝謝您的參與及提供知識結晶~~

no3-taco

回復 6# 准提部林

p = p + 1 '修改時忘記拿掉

我不是老手，只是剛剛練習寫正好有寫出來

准提部林

回復 7# no3-taco


～～只是剛剛練習寫〔正好〕有寫出來～～　

那就更不簡單，我是腦神經快轉不過來了！
這題本以為不會有人關注，沒想到還是得到兩個不同解法，真是感激您們的關注！
繼續期待其它解法！！

需求結果２也可再想想～～

bobomi

Sub q77()

  Cells.Clear
   
'**** 上、下、左、右  copy from  ML089 ****
  右 = [{0, 1, "→","┌"}]: 下 = [{1,0,"↓","┐"}]: 左 = [{0,-1,"←","┘"}]: 上 = [{-1, 0,"↑","└"}]
  
  yx = Array(右, 下, 左, 上)

  r = 10
  c = 10
  Value = 1
  Cells(r, c) = Value
  For Count = 1 To  6^2
  rc = yx(方向 Mod 4)
  n = CLng(Count / 2 + 0.001)
  For Repeat = 1 To n
      r = r + rc(1)
      c = c + rc(2)
      Value = Value + 1
      If Repeat = n Then
         Cells(r, c) = yx((方向 + 1) Mod 4)(4) & " " & Value
      Else
         Cells(r, c) = rc(3) & " " & Value
      End If
  Next
  方向 = 方向 + 1
  Next


' 最後 ◎ ● 這2符號請自己處理

End Sub

ML089

回復 9# bobomi

加入 bobomi 的
右 = [{0, 1, "→","┌"}]: 下 = [{1,0,"↓","┐"}]: 左 = [{0,-1,"←","┘"}]: 上 = [{-1, 0,"↑","└"}]
效果圖二就出來了

Option Base 1
Sub 以旋轉方式填入值()

    xc = 10: yc = 10    '中心位置

    右 = [{0, 1, "→","┌"}]: 下 = [{1,0,"↓","┐"}]: 左 = [{0,-1,"←","┘"}]: 上 = [{-1, 0,"↑","└"}]
    yx = Array(右, 下, 左, 上)    '控制方向及順時轉向

    '    右 = [{0, 1, "→","└"}]: 下 = [{1,0,"↓","┌"}]: 左 = [{0,-1,"←","┐"}]: 上 = [{-1, 0,"↑","┘"}]
    '    yx = Array(下, 右, 上, 左)    '控制方向及逆時轉向

    n = InputBox("輸入排列數字", , 25)
    [A1:Z26].ClearContents

    x = xc: y = yc: xp1 = x: yp1 = y
    Cells(x, y) = 1
    f1 = "": f2 = ""
    For i = 2 To n
        ds = [{"","","",""}]
        For j = 1 To 4    '四個方向
            yy = yx(j)(1): xx = yx(j)(2)
            If Cells(y + yy, x + xx) = "" Then
                ds(j) = ((y + yy - yc) ^ 2 + (x + xx - xc) ^ 2) * 10 + j    '距離*10+方向
            End If
        Next
        k = Application.Min(ds) Mod 10    '取距離原點最短及排列最前方向

        y = y + yx(k)(1)
        x = x + yx(k)(2)
        Cells(y, x) = i

        方向符號 = IIf(i = 2, "◎", yx(k)(3 + IIf(k = kp1, 0, 1)))
        Cells(yp1, xp1) = Cells(yp1, xp1) & 方向符號
        yp1 = y: xp1 = x: kp1 = k

        'Application.Wait TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 1)
    Next
    Cells(yp1, xp1) = Cells(yp1, xp1) & "●"
End Sub