'「Excelでライフゲーム」のメインコードです。
'ソフトではWin32APIのSleepを使用していますが、このコードではApplication.Waitで代用しています。
'ソフトでは、セル範囲[A1:CV100]に条件付き書式を設定し、値が1であれば色がつくようにしています。
'///宣言セクション///
Public varArea As Variant, varEmpty As Variant

Type CellsStatus
    x As Long: y As Long   'セルの位置
    v As Long              '隣接セル数格納
    ys As Long: ye As Long '隣接セル行格納
    xs As Long: xe As Long '隣接セル列格納
End Type

Public cs() As CellsStatus

Sub Initial_Setting_Rnd() 'セルをランダムに配置 Dim i As Long, j As Long Randomize With Range("A1:CV100") .ClearContents varArea = .Value For i = 1 To 100 For j = 1 To 100 If Int(Rnd() * 10) < 4 Then varArea(i, j) = 1 Next Next .Value = varArea End With End Sub
Sub Area_Clear() '範囲をクリア Range("A1:CV200").ClearContents End Sub
Sub LifeGame_Main() 'ライフゲームメイン Call Next_Generation(30) '30世代おくる。数値を変更するとおくる世代数を変更できます。 '数値は最大100程度に。あまりに大きいとコンピュータに負荷がかかります End Sub
Private Sub Next_Generation(ByVal c As Long) '次世代処理サブルーチン Dim i As Long If Value_Setting() Then '配置確認関数 MsgBox "セルの数が0です。セルを配置してください。", vbExclamation: Exit Sub End If For i = 1 To c If Stage_Set() Then MsgBox "セルは死滅しました。", vbInformation: Exit Sub End If Application.Wait [Now() + "0:00:00.1"] Next End Sub
Private Function Value_Setting() As Boolean '配置確認関数 Dim i As Long, j As Long, c As Long Erase cs varArea = Range("A1:CV100").Value varEmpty = Range("A101:CV200").Value For i = 1 To 100 For j = 1 To 100 If varArea(i, j) = 1 Then c = c + 1 ReDim Preserve cs(1 To c) cs(c).y = i: cs(c).x = j Else varArea(i, j) = Empty End If Next Next Value_Setting = CBool(c = 0) End Function
Private Function Stage_Set() As Boolean '次世代処理メイン関数 Dim i As Long, j As Long, k As Long, c As Long, varBk As Variant Dim myCS() As CellsStatus varBk = varEmpty For i = LBound(cs) To UBound(cs) With cs(i) If .y = 1 Then .ys = 1 Else .ys = .y - 1 If .y = 100 Then .ye = 100 Else .ye = .y + 1 If .x = 1 Then .xs = 1 Else .xs = .x - 1 If .x = 100 Then .xe = 100 Else .xe = .x + 1 For j = .ys To .ye For k = .xs To .xe If Not (j = .y And k = .x) Then If varArea(j, k) = 1 Then .v = .v + 1 '隣接セル数カウント Else varBk(j, k) = varBk(j, k) + 1 '隣接セルに+1 End If End If Next Next If .v = 2 Or .v = 3 Then '現世代の生き残り確認 .v = 0 c = c + 1 ReDim Preserve myCS(1 To c) myCS(c) = cs(i) End If End With Next For i = LBound(cs) To UBound(cs) '次世代誕生確認 With cs(i) For j = .ys To .ye For k = .xs To .xe If varBk(j, k) = 3 Then varBk(j, k) = 0 c = c + 1 ReDim Preserve myCS(1 To c) myCS(c).y = j: myCS(c).x = k End If Next Next End With Next cs = myCS varArea = varEmpty If 0 < c Then For i = LBound(cs) To UBound(cs) '生き残り+次世代セット varArea(cs(i).y, cs(i).x) = 1 Next End If Range("A1:CV100").Value = varArea Stage_Set = CBool(c = 0) End Function