Excel（エクセル）活用コミュの鑑賞用VBA

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub ライフ()
MsgBox ("やめたくなったらESCキーを押してください")
i = InputBox("増加速度を半角数字で入力基本50")
Cells.Select
Selection.ClearContents
Range("A1:AX50").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Selection.ColumnWidth = 2.3
ActiveWindow.Zoom = 75

x = 25
y = 25
Cells(x, y).Select
G = True
Do While G = True
Randomize
a = Int(Rnd * 8)
If x > 1 And y > 1 Then
If a = 1 Then
x = x - 1
y = y - 1
Cells(x, y).Select
Selection.Value = "●"
ElseIf a = 2 Then
x = x - 1
y = y
Cells(x, y).Select
Selection.Value = "●"
ElseIf a = 3 Then
x = x - 1
y = y + 1
Cells(x, y).Select
Selection.Value = "●"
ElseIf a = 4 Then
x = x + 1
y = y - 1
Cells(x, y).Select
Selection.Value = "●"
ElseIf a = 5 Then
x = x + 1
y = y
Cells(x, y).Select
Selection.Value = "●"
ElseIf a = 0 Then

Cells(x, y).Select
Selection.Value = "●"
ElseIf a = 6 Then
x = x + 1
y = y + 1
Cells(x, y).Select
Selection.Value = "●"
ElseIf a = 7 Then
x = x
y = y + 1
Cells(x, y).Select
Selection.Value = "●"
End If
End If
If x > 49 Or y > 49 Then
x = 0
y = 0
x = Int(Rnd * 48) + 1
y = Int(Rnd * 48) + 1
Cells(x, y).Select
Selection.Value = "●"
ElseIf x <= 1 Or y <= 1 Then
x = 0
y = 0
x = Int(Rnd * 48) + 1
y = Int(Rnd * 48) + 1
Cells(x, y).Select
Selection.Value = "●"
End If
Sleep (i)
Loop
End Sub

エクセル2003で作ったVBA
いまいちスマートなプログラムではないけれども、ふと仕事に疲れたときに見ているだけで暇がつぶせるものを！と思い作成
本当は、ライフゲームを作ってみたかったんだ・・
分裂とぶつかった時に消える処理が分からなかったので断念。
ライフゲーム作れる人居ますか？

コメント(9)

最初
全て
最新の40件

[2] mixiユーザー 03月30日 10:48

できれば、Excelのセル函数だけ作ったゲームがどのようなものか公開できませんか？
VBAが要らないのであれば、より多くの人が分かりやすくExcelで楽しむことが出来ると思うので。

[3] mixiユーザー 04月03日 23:39

面白そうな話題なのに、誰もやらないみたいなので^-^;;; VBAでコンウェイのLifeGameを作ってみました。0が死亡で1が生存セルです。セル範囲を全選択して「書式＞条件付き書式」でセル背景色を指定してやれば幸せになれるかもしれません^-^:
--------------------------------------
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SIZE_X = 64 'フィールド縦サイズ
Private Const SIZE_Y = 64 'フィールド横サイズ
Private Const WAIT = 100 '待機時間(ms)
Private LifeArea() As Variant 'フィールド（現在状態）
Private LifeNext() As Variant 'フィールド（次世代）

Public Sub Main()
On Error GoTo ErrorHandler
Application.EnableCancelKey = xlErrorHandler
Dim X As Long: Dim Y As Long: Dim Temp As Long
LifeArea = Range(Cells(1, 1), Cells(SIZE_X, SIZE_Y)) '画面上のデータを取得
Select Case MsgBox("ランダムパターンを作成しますか？" & vbCr & _
"「いいえ」で現在画面の続きを実行します。" & vbCr & _
"（実行中、停止するにはESCキーを押してください。）", _
vbYesNoCancel + vbInformation, "実行開始")
Case vbYes 'ランダムパターン作成
Randomize
For X = 1 To SIZE_X: For Y = 1 To SIZE_Y
LifeArea(X, Y) = Abs(Rnd() * 10 < 5)
Next: Next
Case vbNo 'エラーデータ補正
For X = 1 To SIZE_X: For Y = 1 To SIZE_Y
If LifeArea(X, Y) <> 1 Then LifeArea(X, Y) = 0
Next: Next
Case vbCancel: Exit Sub '終了
End Select
Do 'メイン処理
LifeNext = LifeArea
For X = 1 To SIZE_X: For Y = 1 To SIZE_Y
If LifeArea(X, Y) Then
Temp = LivesCount(X, Y)
If Temp = 2 Then
ElseIf Temp = 3 Then
Else: LifeNext(X, Y) = 0 '生→死
End If
Else
If LivesCount(X, Y) = 3 Then LifeNext(X, Y) = 1 '空→発生
End If
Next: Next
Range(Cells(1, 1), Cells(SIZE_X, SIZE_Y)) = LifeNext '画面更新
LifeArea = LifeNext '次処理準備
Call Sleep(WAIT)
DoEvents
Loop
ErrorHandler:
End Sub

Private Function LivesCount(X As Long, Y As Long) As Long
LivesCount = 0
If GetData(X - 1, Y - 1) Then LivesCount = LivesCount + 1
If GetData(X - 1, Y) Then LivesCount = LivesCount + 1
If GetData(X - 1, Y + 1) Then LivesCount = LivesCount + 1
If GetData(X, Y - 1) Then LivesCount = LivesCount + 1
If GetData(X, Y + 1) Then LivesCount = LivesCount + 1
If GetData(X + 1, Y - 1) Then LivesCount = LivesCount + 1
If GetData(X + 1, Y) Then LivesCount = LivesCount + 1
If GetData(X + 1, Y + 1) Then LivesCount = LivesCount + 1
End Function

Private Function GetData(X As Long, Y As Long) As Long
On Local Error GoTo OutOfRange
GetData = LifeArea(X, Y): Exit Function
OutOfRange:
Err = 0: GetData = 0
End Function

[4] mixiユーザー 04月06日 10:10

この１と０の画面をシート２で起動させ、シート１には１ならバックカラー黒、０ならバックカラー白というふうに連動させれば、見た目もライフゲームになりそうですね。
感覚的に
もしシート2の（ｘ、ｙ）が１ならシート１の（ｘ、ｙ）が黒
もしシート2の（ｘ、ｙ）が０ならシート１の（ｘ、ｙ）が白
と簡単にいけばいいのですが・・＾＾；

[5] mixiユーザー 04月06日 11:16

そんな面倒なことをしなくても、背景色は簡単に変えられますよ。僕もつい最近知って驚いたのですが^^;

1. セルを全選択します
2. ファイルメニューの「書式＞条件付き書式」をクリック
3. 「書式」をクリックで表示設定。セルの値が1の時は背景色を黒にします。
　　「追加>>」をクリックすると、2つ目以降の条件が入力できるようになります。
4. OKを押して戻ります
5. その後、マクロ実行

画像を参考に設定してみてください。

[7] mixiユーザー 04月06日 23:52

Cells.Select
Selection.ColumnWidth = 1.8
ActiveWindow.Zoom = 85
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="1"
With Selection.FormatConditions(1).Interior
.ColorIndex = 1
.Pattern = xlSolid
End With
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="0"
Selection.FormatConditions(2).Font.ColorIndex = 2
With Selection.FormatConditions(2).Interior
.ColorIndex = 2
.Pattern = xlSolid
End With

背景色、文字色、列幅、表示の大きさ変更の追加

[9] mixiユーザー 05月23日 00:09

ニコ動にJavaScriptでライフゲーム作る動画があったので、ご参考までに…。

■１曲終わるまでにプログラムを打ってみたその５　ライフゲーム
http://www.nicovideo.jp/watch/sm1180133

ログインすると、みんなのコメントがもっと見れるよ