返回列表 上一主題 發帖

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

回復 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
1

評分人數

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 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. Sub arrX2(numX&, n&, k&)
  8. Dim cx&, cy&, arr, arr2, arr3
  9. arr = Array(0, 1, 0, -1, 0, 1)
  10. arr2 = Array("┐", "┘", "└", "┌", "●")
  11. arr3 = Array("", "↓", "←", "↑", "→")

  12. If numX <> 1 Then
  13.     arrX2 numX - 2, n, k
  14.     p = (numX - 1) / 2  '(增量)位移量
  15.     For i = 1 To 4
  16.         For j = 0 To numX - 2   
  17.             cx = ActiveCell.Column + p * arr(i) + arr(i + 1) * (j - p + 1)
  18.             cy = ActiveCell.Row + p * arr(i - 1) + arr(i) * (j - p + 1)
  19.             If k = 0 Then
  20.                 If i = 1 And j = 0 Then
  21.                     Cells(cy, cx) = arr2(0)
  22.                 ElseIf i < 4 And j = numX - 2 Then
  23.                     Cells(cy, cx) = arr2(i)
  24.                 ElseIf j = numX - 2 And numX = n Then
  25.                     Cells(cy, cx) = arr2(i)
  26.                 Else
  27.                     Cells(cy, cx) = arr3(i)
  28.                 End If
  29.             Else
  30.                 k = k + 1
  31.                 Cells(cy, cx) = k
  32.             End If
  33.         Next j
  34.     Next i
  35. Else
  36.     ActiveCell = IIf(k > 0, k, "◎")
  37. End If
  38. End Sub
複製代碼
1

評分人數

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

回復 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. Sub 方陣2()
  30. Dim 邊界 As Byte
  31. Dim 邊 As Byte
  32. Dim X0 As Byte
  33. Dim Y0 As Byte
  34. Dim n As Integer
  35. Cells(5, 5).CurrentRegion = ""
  36. 邊界 = (Cells(1, 2) - 1) / 2
  37. X0 = 邊界 + 5: Y0 = 邊界 + 5
  38. n = 1: X = X0: Y = Y0: 邊 = 1
  39. Cells(Y, X) = "◎": n = n + 1
  40. 向右:
  41. If n = (邊 * 2 + 1) ^ 2 And 邊 < 邊界 Then 邊 = 邊 + 1
  42. If n = (邊 * 2 + 1) ^ 2 And 邊 = 邊界 Then GoTo 結尾
  43. If X + 1 - X0 > 邊 Then GoTo 向下
  44. X = X + 1
  45. If X - X0 = 邊 Then Cells(Y, X) = "┐" Else Cells(Y, X) = "→"
  46. n = n + 1: GoTo 向右
  47. 向下:
  48. If Y + 1 - Y0 > 邊 Then GoTo 向左
  49. Y = Y + 1
  50. If Y - Y0 = 邊 Then Cells(Y, X) = "┘" Else Cells(Y, X) = "↓"
  51. n = n + 1: GoTo 向下
  52. 向左:
  53. If X - 1 - X0 < -邊 Then GoTo 向上
  54. X = X - 1
  55. If X - X0 = -邊 Then Cells(Y, X) = "└" Else Cells(Y, X) = "←"
  56. n = n + 1: GoTo 向左
  57. 向上:
  58. If Y - 1 - Y0 < -邊 Then GoTo 向右
  59. Y = Y - 1
  60. If Y - Y0 = -邊 Then Cells(Y, X) = "┌" Else Cells(Y, X) = "↑"
  61. n = n + 1: GoTo 向上
  62. 結尾:
  63. X = X + 1: Cells(Y, X) = "●"
  64. End Sub
複製代碼

數獨.rar (48.65 KB)

旋轉方陣.rar (15.84 KB)

1

評分人數

TOP

回復 17# n7822123


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

TOP

        靜思自在 : 待人退一步,愛人寬一寸,就會活得很快樂。
返回列表 上一主題