返回列表 上一主題 發帖

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

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
1# 跳轉到 »
發表於 2015-10-24 22:45 | 顯示全部帖子
  1. Option Base 1
  2. Sub 以旋轉方式填入值()

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

  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

  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
複製代碼
1

評分人數

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
2#
發表於 2015-10-25 09:06 | 顯示全部帖子
回復 3# 准提部林

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

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

'控制方向及轉向  
yx = Application.Transpose(Application.Transpose(Array(右, 下, 左, 上))) '第一步向右，順時排列
圖片 1.jpg
利用上式中 ... 右, 下, 左, 上 的放置順序來控制方向及轉向
第1位置控制第一步方向，可以放置 ..... 右, 下, 左, 上 .... 來改變。
第2~3位置控制順、逆排列方向。

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

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

評分人數

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
3#
發表於 2015-10-26 12:14 | 顯示全部帖子
回復 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
1

評分人數

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

        靜思自在 : 【是否發揮了良能？】人間壽命因為短暫，才更顯得珍貴。難得來一趟人間，應問是否為人間發揮了自己的良能，而不要一味求長壽。
返回列表 上一主題