Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


18980 / 76733 ←次へ | 前へ→

【63190】エクセルでのライフゲームについて
質問  cron  - 09/10/14(水) 12:52 -

引用なし
パスワード
   以下は自分が作ったVBAでのライフゲームなのですが
一度黒くなったセルはもう二度と黒くならないようにしたいです。
どのようにすればいいのかご教授ください。
また、できれば以下のプログラムにパラメータを組み込みたいと考えています。
それは確率です。たとえば、8近傍のセルのなかに1つでも黒いセルがあったとき
中心のセルは1/2で黒くなるなどです。
もしわかる方がいましたらこれも含めてご教授ください。
よろしくお願いいたします。

Sub lifegame3()
  Worksheets("sheet1").Activate
  Dim i As Integer, j As Integer, n As Integer, x As Integer
  Dim ip As Integer, im As Integer, jp As Integer, jm As Integer
  Dim g As Integer
        
  'セルの数
  n = 50
  Dim k(50, 50) As Integer, k2(50, 50) As Integer
  
  '世代数
  t = Range("AZ52").Value
  
  
  '初期条件
  Randomize
  For i = 1 To n
    For j = 1 To n
      If (Rnd() < 0.4) Then
        Cells(i, j).Interior.ColorIndex = 1
        k(i, j) = 1
      Else
        Cells(i, j).Interior.ColorIndex = 2
        k(i, j) = 0
      End If
    Next
  Next


  For g = 1 To t
    
    For i = 1 To n
      For j = 1 To n
        '端のセルの処理
        ip = (i Mod n) + 1
        im = n - ((n + 1 - i) Mod n)
        jp = (j Mod n) + 1
        jm = n - ((n + 1 - j) Mod n)
        x = k(im, jm) + k(i, jm) + k(ip, jm) + k(im, j) + k(ip, j) + k(im, jp) + k(i, jp) + k(ip, jp)
        If (k(i, j) = 1) Then
          If (x = 2 Or x = 3) Then
            k2(i, j) = 1
          Else
            Cells(i, j).Interior.ColorIndex = 2
            k2(i, j) = 0
          End If
        Else
          If (x = 3) Then
            Cells(i, j).Interior.ColorIndex = 1
            k2(i, j) = 1
          Else
            k2(i, j) = 0
          End If
        End If
      Next
    Next
    
    For i = 1 To n
      For j = 1 To n
        k(i, j) = k2(i, j)
      Next
    Next
    Range("BB52").Select
    Selection.Value = g
  Next
End Sub
3 hits

【63190】エクセルでのライフゲームについて cron 09/10/14(水) 12:52 質問
【63191】Re:エクセルでのライフゲームについて seg 09/10/14(水) 13:39 発言
【63211】Re:エクセルでのライフゲームについて cron 09/10/15(木) 14:38 発言

18980 / 76733 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free