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

准提部林

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

１．設一個方陣或矩陣為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

　

准提部林

回復 17# n7822123


這題目的是看不同的解法, 集思廣義!
貴解測試完全可用, 謝謝參與!

n7822123

回復 1# 准提部林

不知道現在回會不會太晚~
我用很直覺的寫法，走到底就轉彎~

1. Sub 方陣1()
   
2. Dim 邊界 As Byte
   
3. Dim 邊 As Byte
   
4. Dim X0 As Byte
   
5. Dim Y0 As Byte
   
6. Dim n As Integer
   
7. Cells(5, 5).CurrentRegion = ""
   
8. 邊界 = (Cells(1, 2) - 1) / 2
   
9. X0 = 邊界 + 5: Y0 = 邊界 + 5
   
10. n = 1: X = X0: Y = Y0: 邊 = 1
    
11. Cells(Y, X) = n: n = n + 1
    
12. 向右:
    
13. If n = (邊 * 2 + 1) ^ 2 And 邊 < 邊界 Then 邊 = 邊 + 1
    
14. If n = (邊 * 2 + 1) ^ 2 And 邊 = 邊界 Then GoTo 結尾
    
15. If X + 1 - X0 > 邊 Then GoTo 向下
    
16. X = X + 1: Cells(Y, X) = n: n = n + 1: GoTo 向右
    
17. 向下:
    
18. If Y + 1 - Y0 > 邊 Then GoTo 向左
    
19. Y = Y + 1: Cells(Y, X) = n: n = n + 1: GoTo 向下
    
20. 向左:
    
21. If X - 1 - X0 < -邊 Then GoTo 向上
    
22. X = X - 1: Cells(Y, X) = n: n = n + 1: GoTo 向左
    
23. 向上:
    
24. If Y - 1 - Y0 < -邊 Then GoTo 向右
    
25. Y = Y - 1: Cells(Y, X) = n: n = n + 1: GoTo 向上
    
26. 結尾:
    
27. X = X + 1: Cells(Y, X) = n
    
28. End Sub
    
29. 
    
30. Sub 方陣2()
    
31. Dim 邊界 As Byte
    
32. Dim 邊 As Byte
    
33. Dim X0 As Byte
    
34. Dim Y0 As Byte
    
35. Dim n As Integer
    
36. Cells(5, 5).CurrentRegion = ""
    
37. 邊界 = (Cells(1, 2) - 1) / 2
    
38. X0 = 邊界 + 5: Y0 = 邊界 + 5
    
39. n = 1: X = X0: Y = Y0: 邊 = 1
    
40. Cells(Y, X) = "◎": n = n + 1
    
41. 向右:
    
42. If n = (邊 * 2 + 1) ^ 2 And 邊 < 邊界 Then 邊 = 邊 + 1
    
43. If n = (邊 * 2 + 1) ^ 2 And 邊 = 邊界 Then GoTo 結尾
    
44. If X + 1 - X0 > 邊 Then GoTo 向下
    
45. X = X + 1
    
46. If X - X0 = 邊 Then Cells(Y, X) = "┐" Else Cells(Y, X) = "→"
    
47. n = n + 1: GoTo 向右
    
48. 向下:
    
49. If Y + 1 - Y0 > 邊 Then GoTo 向左
    
50. Y = Y + 1
    
51. If Y - Y0 = 邊 Then Cells(Y, X) = "┘" Else Cells(Y, X) = "↓"
    
52. n = n + 1: GoTo 向下
    
53. 向左:
    
54. If X - 1 - X0 < -邊 Then GoTo 向上
    
55. X = X - 1
    
56. If X - X0 = -邊 Then Cells(Y, X) = "└" Else Cells(Y, X) = "←"
    
57. n = n + 1: GoTo 向左
    
58. 向上:
    
59. If Y - 1 - Y0 < -邊 Then GoTo 向右
    
60. Y = Y - 1
    
61. If Y - Y0 = -邊 Then Cells(Y, X) = "┌" Else Cells(Y, X) = "↑"
    
62. n = n + 1: GoTo 向上
    
63. 結尾:
    
64. X = X + 1: Cells(Y, X) = "●"
    
65. End Sub

複製代碼

准提部林

＜十字非空檢查法＞
Sub 數字矩陣_十字非空檢查法()
Dim i&, xR As Range, R&, C&, N, j&, k&
N = InputBox("輸入欄列數", , 11)
Cells.ClearContents
Set xR = Cells(N / 2 + 2, N / 2 + 2): xR = 1: Set xR = xR(1, 2)
For i = 2 To N * N
　　For j = 1 To 4
　　　　If xR(0, 0).Resize(3, 3).Item(j * 2) <> "" Then k = k & j
　　Next j
　　If k < 5 Then R = Mid("1201", k, 1): C = Mid("0112", k, 1)
　　xR = i:  Set xR = xR(R, C): k = 0
　　Sleep 10
Next i
End Sub
　
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 方向矩陣_十字非空檢查法()
Dim i&, xR As Range, R&, C&, N, j&, k&, T$
N = InputBox("輸入欄列數", , 11)
Cells.ClearContents
Set xR = Cells(N / 2 + 2, N / 2 + 2): xR = "◎": Set xR = xR(1, 2)
For i = 2 To N * N - 1
　　For j = 1 To 4
　　　　If xR(0, 0).Resize(3, 3).Item(j * 2) <> "" Then k = k & j
　　Next j
　　If k < 5 Then
　　　　R = Mid("1201", k, 1): C = Mid("0112", k, 1)
　　　　T = Mid("←↓↑→", k, 1): xR = Mid("┘┐└┌", k, 1)
　　End If
　　If xR = "" Then xR = T
　　Set xR = xR(R, C): k = 0
　　Sleep 10
Next i
xR = "●"
End Sub

准提部林

＜牆角摸索法＞
Sub 數字矩陣_牆角摸索法()
Dim i&, xR As Range, R&, C&, N
N = InputBox("輸入欄列數", , 11)
Cells.ClearContents
Set xR = Cells(N / 2 + 2, N / 2 + 2): xR = 1: Set xR = xR(1, 2)
For i = 2 To N * N
　　If xR(1, 0) <> "" And xR(2, 1) = "" Then R = 2: C = 1
　　If xR(0, 1) <> "" And xR(1, 0) = "" Then R = 1: C = 0
　　If xR(1, 2) <> "" And xR(0, 1) = "" Then R = 0: C = 1
　　If xR(2, 1) <> "" And xR(1, 2) = "" Then R = 1: C = 2
　　xR = i:  Set xR = xR(R, C)
　　Sleep 10
Next i
End Sub
　
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 方向矩陣_牆角摸索法()
Dim i&, xR As Range, R&, C&, T$, N
N = InputBox("輸入欄列數", , 11)
Cells.ClearContents
Set xR = Cells(N / 2 + 2, N / 2 + 2):  xR = "◎":  Set xR = xR(1, 2)
For i = 2 To N * N - 1
    If xR(1, 0) <> "" And xR(2, 1) = "" And xR(0, 1) = "" Then R = 2: C = 1: xR = "┐": T = "↓"
    If xR(0, 1) <> "" And xR(1, 0) = "" And xR(1, 2) = "" Then R = 1: C = 0: xR = "┘": T = "←"
    If xR(1, 2) <> "" And xR(0, 1) = "" And xR(2, 1) = "" Then R = 0: C = 1: xR = "└": T = "↑"
    If xR(2, 1) <> "" And xR(1, 2) = "" And xR(1, 0) = "" Then R = 1: C = 2: xR = "┌": T = "→"
    If xR = "" Then xR = T
    Set xR = xR(R, C)
    Sleep 10
Next i
xR = "●"
End Sub

准提部林

只會基本的Range判定方法，以下程式碼供參考，
對初學VBA者應很容易看得懂：
＜四輪定位法＞
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
　
Sub 數字矩陣_四輪定位法()
Dim N, xR As Range, M(1 To 4) As Range, C%, R%, X%, Y%
N = InputBox("請輸入方陣欄列數", , 11)
Cells.ClearContents
Set xR = Cells(N / 2 + 2, N / 2 + 2): Set M(1) = xR(2)
For i = 2 To 4: Set M(i) = xR: Next
R = 1: C = 2
For j = 1 To N * N
　　xR = j: Set xR = xR(R, C): X = xR.Row: Y = xR.Column
　　If X < M(1).Row And Y > M(1).Column Then R = 2: C = 1: Set M(1) = xR
　　If X > M(2).Row And Y > M(2).Column Then R = 1: C = 0: Set M(2) = xR
　　If X > M(3).Row And Y < M(3).Column Then R = 0: C = 1: Set M(3) = xR
　　If X < M(4).Row And Y < M(4).Column Then R = 1: C = 2: Set M(4) = xR
　　Sleep 10
101: Next
End Sub

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 方向矩陣_四輪定位法()
Dim N, xR As Range, M(1 To 4) As Range, C%, R%, X%, Y%, T$
N = InputBox("請輸入方陣欄列數", , 11)
Cells.ClearContents
Set xR = Cells(N / 2 + 2, N / 2 + 2): Set M(1) = xR(2)
For i = 2 To 4: Set M(i) = xR: Next
R = 1: C = 2: T = "◎"
For j = 1 To N * N - 1
　　If xR = "" Then xR = T
　　Set xR = xR(R, C): X = xR.Row: Y = xR.Column
　　If X < M(1).Row And Y > M(1).Column Then R = 2: C = 1: T = "↓": Set M(1) = xR: xR = "┐"
　　If X > M(2).Row And Y > M(2).Column Then R = 1: C = 0: T = "←": Set M(2) = xR: xR = "┘"
　　If X > M(3).Row And Y < M(3).Column Then R = 0: C = 1: T = "↑": Set M(3) = xR: xR = "└"
　　If X < M(4).Row And Y < M(4).Column Then R = 1: C = 2: T = "→": Set M(4) = xR: xR = "┌"
　　Sleep 10
101: Next
xR = "●"
End Sub

准提部林

回復 9# bobomi

謝謝提供精心之作,
也謝謝特來參與, 感恩~~

no3-taco

回復 8# 准提部林

沒有寫得很好，一開始就只考慮到對稱性
但是還是有符合題目需求，貼上來讓大家指導順便修正哪裡還有問題

1. Sub testarrX2()  '這裡執行
   
2. Cells.Clear
   
3. Dim n&: n = 15        '只能奇數
   
4. Cells(11, 8).Select    '=>足夠填充的位置
   
5. arrX2 n, n, 0         '奇數方陣 ,固定值 ,(0=>符號表式,大於0數字=>序列表示)
   
6. End Sub
   
7. 
   
8. Sub arrX2(numX&, n&, k&)
   
9. Dim cx&, cy&, arr, arr2, arr3
   
10. arr = Array(0, 1, 0, -1, 0, 1)
    
11. arr2 = Array("┐", "┘", "└", "┌", "●")
    
12. arr3 = Array("", "↓", "←", "↑", "→")
    
13. 
    
14. If numX <> 1 Then
    
15.     arrX2 numX - 2, n, k
    
16.     p = (numX - 1) / 2  '(增量)位移量
    
17.     For i = 1 To 4
    
18.         For j = 0 To numX - 2   
    
19.             cx = ActiveCell.Column + p * arr(i) + arr(i + 1) * (j - p + 1)
    
20.             cy = ActiveCell.Row + p * arr(i - 1) + arr(i) * (j - p + 1)
    
21.             If k = 0 Then
    
22.                 If i = 1 And j = 0 Then
    
23.                     Cells(cy, cx) = arr2(0)
    
24.                 ElseIf i < 4 And j = numX - 2 Then
    
25.                     Cells(cy, cx) = arr2(i)
    
26.                 ElseIf j = numX - 2 And numX = n Then
    
27.                     Cells(cy, cx) = arr2(i)
    
28.                 Else
    
29.                     Cells(cy, cx) = arr3(i)
    
30.                 End If
    
31.             Else
    
32.                 k = k + 1
    
33.                 Cells(cy, cx) = k
    
34.             End If
    
35.         Next j
    
36.     Next i
    
37. Else
    
38.     ActiveCell = IIf(k > 0, k, "◎")
    
39. End If
    
40. End Sub

複製代碼

GBKEE

回復 1# 准提部林
Sub 以旋轉方式填入值() 局限在[A1:Z26]

1. Sub testarr()
   
2. arrX 7, 1  '2003 '階數須是奇數,如偶數執行有堆疊空間不足的錯誤
   
3. End Sub

複製代碼

Sub Ex()
    '矩陣可為5*5,6*6,7*7,..256*256...視Excel版本
    Dim xNo As Double, Rng As Range, Rc As Double, i As Integer
    ActiveSheet.UsedRange.Clear
    xNo = Application.InputBox("輸入排列數字", , 25, Type:=1)
    Rc = Application.Evaluate("CEILING(Sqrt(" & xNo & "),1)")
    If Rc Mod 2 <> 0 Then i = 1
    If Int(Rc / 2) + i > Int(Columns.Count / 2) Then
       MsgBox "輸入排列數字" & xNo & "的欄位數 " & Int(Rc / 2) + i & vbLf & "大於 工作表之總欄位/ 2  =>" & Columns.Count / 2
       End
    End If
    Set Rng = Cells(Int(Rc / 2) + i, Int(Rc / 2) + i)   '以A1為相對位置的中心儲存格
    Rng.Select
    Rng.Interior.Color = vbRed
    Rng = 1
    Do
        '右,下,左,上 順時鐘方向
        Do
            If Rng >= Rc * Rc Then End
            Rng.Offset(, 1) = Rng + 1
            Set Rng = Rng.Offset(, 1)   '右移一欄
        Loop Until Rng.Offset(1) = ""   '下一列 = ""
        
        Do
            Rng.Offset(1) = Rng + 1
            Set Rng = Rng.Offset(1)      '下移一列
        Loop Until Rng.Offset(, -1) = "" '左一欄 = ""
   
        Do
            If Rng >= Rc * Rc Then End
            Rng.Offset(, -1) = Rng + 1
            Set Rng = Rng.Offset(, -1)  '左移一欄
        Loop Until Rng.Offset(-1) = ""  '上一列 = ""
   
        Do
            Rng.Offset(-1) = Rng + 1
            Set Rng = Rng.Offset(-1)    '上移一列
        Loop Until Rng.Offset(, 1) = "" '右一欄 = ""
    Loop
   
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