返回列表 上一主題 發帖

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

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

本帖最後由 准提部林 於 2015-10-27 14:50 編輯

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

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

需求效果1:          需求效果2:
A999.gif      B999.gif
 
尋求VBA任何解法,
個人只會〔四輪定位〕法,為避免大家有先入為主的看法,暫不提供程式碼;

希望路過大大不吝提供更多方法,
先此謝過∼∼
 
===2015.10.27 補充===================
程式碼請見14∼16樓,
以非專業自學者而言,只會用最基本的儲存格判斷,所以對初學者也應容易看懂,

而其它大大的程式碼,實為正規的解法,更有參考價值,
再度謝謝各位參與的大大們∼∼

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

回復 2# ML089


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

TOP

回復 5# no3-taco


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

TOP

回復 7# no3-taco


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

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

需求結果2也可再想想∼∼

TOP

回復 9# bobomi

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

TOP

只會基本的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
1

評分人數

    • ML089: 精品文章金錢 + 5

TOP

<牆角摸索法>
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
1

評分人數

    • ML089: 精品文章金錢 + 5

TOP

<十字非空檢查法>
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
1

評分人數

    • ML089: 精品文章金錢 + 5

TOP

回復 17# n7822123


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

TOP

        靜思自在 : 得理要饒人,理直要氣和。
返回列表 上一主題