Excel+VBA製作小應用：元胞自動機

視頻在6:50左右開始講了一個Cellular Automaton的規則，根據這個規則我做了個有意思的Excel，下面開始說做法。

一、準備界面

為了模擬方形單元格，我把表格全選，行高和列寬都設置成3mm.在Excel選項——高級——顯示——標尺單位中，設置成毫米。在頁面布局視圖中，可以設置行高和列寬。

然後我選了一個50*50的區域，外邊框設置的是黑色，中間框線設置的深色50%，字體大小設置為1。在條件格式中設置了兩個規則，如下：

這時候背景應該是全灰的，因為條件格式會把單元格空值也當作=0，為了方便設置單元格內容，利用Worksheet_SelectionChange事件添加如下代碼：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)nIf ActiveCell.Row <= 50 And ActiveCell.Column <= 50 Then ActiveCell.Value = 1nEnd Subn

這時候我們發現，隨便點擊灰色區域的單元格，它就會變成黃色了。

二、邏輯實現

這個元胞自動機遵循以下規則：

1. 當一個被填充的方格有一個或是沒有相鄰已填充方格時，會變成未填充狀態

2. 每個被填充的方格有4個或以上的已填充相鄰方格時，會變成未填充狀態

3. 每個已填充方格有兩個或三個已填充相鄰方格時，保持已填充狀態

4. 每個未填充方格有三個相鄰已填充方格時，會變成已填充狀態

我們要做的是，將單元格區域讀取到一個數組中，然後遍曆數組，根據該規則生成一個新的數組。代碼如下：

Private Sub Cell_Change()nndataArr = Sheet1.Range(Cells(1, 1), Cells(areaWidth, areaHeight))nnDim dataResultArr, cellAroundNum%nReDim dataResultArr(1 To areaWidth, 1 To areaHeight)nnFor i = 1 To areaWidthn For j = 1 To areaHeightnn 相鄰填充方格數 n cellAroundNum = Cell_Around_Num_Check(i, j)n dataResultArr(i, j) = dataArr(i, j)n n 規則 n If dataArr(i, j) = 1 Thenn If cellAroundNum <= 1 Thenn dataResultArr(i, j) = 0n ElseIf cellAroundNum >= 4 Thenn dataResultArr(i, j) = 0n Elsen dataResultArr(i, j) = 1n End Ifn Elsen If cellAroundNum = 3 Then dataResultArr(i, j) = 1n End Ifn n Next jnNext innSheet1.Range(Cells(1, 1), Cells(areaWidth, areaHeight)) = dataResultArrnEnd Subn

這裡檢查相鄰填充方格數時用到了一個Cell_Around_Num_Check函數，這個函數的原理是檢查i行j列單元格周圍的8個單元格，如果單元格在規定區域內且數值為1，則計數一次。函數代碼如下：

Private Function Cell_Around_Num_Check(ByVal i As Integer, ByVal j As Integer) As IntegernnDim cellAroundNum%ncellAroundNum = 0nnDim iCheck%, jCheck%, index%nFor index = 0 To 8n If index <> 4 Thenn n iCheck = i + checkArr(index)(0)n jCheck = j + checkArr(index)(1)n n If iCheck >= 1 And iCheck <= areaWidth And jCheck >= 1 And jCheck <= areaHeight Thenn If dataArr(iCheck, jCheck) = 1 Then cellAroundNum = cellAroundNum + 1n End Ifn n End IfnNext indexnnCell_Around_Num_Check = cellAroundNumnEnd Functionn

在這個函數里我們用到了一個checkArr數組，和前一個方法中的dataArr數組，這兩個公共變數我們都放到代碼部分的最前面進行聲明。

代碼的開始部分如下：

Public areaWidth%nPublic areaHeight%nPublic dataArrnPublic checkArrnPublic gameStatus As BooleannnPublic Sub Cellular_Automaton()nnareaWidth = 50nareaHeight = 50nncheckArr = Array(Array(-1, -1), Array(0, -1), Array(1, -1), _n Array(-1, 0), Array(0, 0), Array(1, 0), _n Array(-1, 1), Array(0, 1), Array(1, 1))n nDon DoEventsn Call Cell_ChangenLoop While (gameStatus)nnEnd Subn

我們定義了公共變數區域寬、高、數據數組、檢查數組。然後在方法中給這些變數進行了賦值，再通過一個無限循環的DO LOOP語句調用了Cell_Change方法。

注意這裡加了一個DoEvents語句，用來釋放控制權避免死循環卡死。這樣我們也可以在程序運行時，通過點擊單元格區域給區域內增加黃色格子，從而干擾元胞自動機的結果。

最後，在區域中隨便點擊一些單元格，注意不要分的太散，然後Alt+F8執行Cellular_Automaton這個宏，就能看到變化了~有沒有一種上帝的感覺~~~

補充：代碼無限運行不能停止太不友好了，新增一個停止的宏。

Public Sub Stop_CA()ngameStatus = FalsenEnd Subn

以上，代碼量較小，照例放在附錄中了。

附錄：

Public areaWidth%nPublic areaHeight%nPublic dataArrnPublic checkArrnPublic gameStatus As BooleannnPublic Sub Stop_CA()ngameStatus = FalsenEnd SubnnPublic Sub Cellular_Automaton()nnareaWidth = 50nareaHeight = 50ngameStatus = TruenncheckArr = Array(Array(-1, -1), Array(0, -1), Array(1, -1), _n Array(-1, 0), Array(0, 0), Array(1, 0), _n Array(-1, 1), Array(0, 1), Array(1, 1))n nDon DoEventsn Call Cell_ChangenLoop While (gameStatus)nnEnd SubnnPrivate Sub Cell_Change()nndataArr = Sheet1.Range(Cells(1, 1), Cells(areaWidth, areaHeight))nnDim dataResultArr, cellAroundNum%nReDim dataResultArr(1 To areaWidth, 1 To areaHeight)nnFor i = 1 To areaWidthn For j = 1 To areaHeightn n 相鄰填充方格數n cellAroundNum = Cell_Around_Num_Check(i, j)n dataResultArr(i, j) = dataArr(i, j)n n 規則n If dataArr(i, j) = 1 Thenn If cellAroundNum <= 1 Thenn dataResultArr(i, j) = 0n ElseIf cellAroundNum >= 4 Thenn dataResultArr(i, j) = 0n Elsen dataResultArr(i, j) = 1n End Ifn Elsen If cellAroundNum = 3 Then dataResultArr(i, j) = 1n End Ifn n Next jnNext innSheet1.Range(Cells(1, 1), Cells(areaWidth, areaHeight)) = dataResultArrnEnd SubnnPrivate Function Cell_Around_Num_Check(ByVal i As Integer, ByVal j As Integer) As IntegernnDim cellAroundNum%ncellAroundNum = 0nnDim iCheck%, jCheck%, index%nFor index = 0 To 8n If index <> 4 Thenn n iCheck = i + checkArr(index)(0)n jCheck = j + checkArr(index)(1)n n If iCheck >= 1 And iCheck <= areaWidth And jCheck >= 1 And jCheck <= areaHeight Thenn If dataArr(iCheck, jCheck) = 1 Then cellAroundNum = cellAroundNum + 1n End Ifn n End IfnNext indexnnCell_Around_Num_Check = cellAroundNumnEnd Functionn

推薦閱讀：