前回の記事
エクセルVBAでライフゲームその2 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
http://blogs.yahoo.co.jp/gogowaten/14606097.html
の補足
上下左右ループ
前々回
前回
赤枠が全体マップ
黒枠が11番のセルの周囲を探索するときの範囲
セルa,b,cはマップ外なので探査しても無意味になる
左右をつなげるには、それぞれ10,15,20が入るようになっていればいい
こうなっていればいいので
右側を左側の外にコピペで
左側が右側に繋がったことになる
上下左右コピペ
後の四隅は対角
これで探査用のシートはOK
例えば表示用がこんな状態のとき探査用のシートは
右のようになっているので
次の世代には
1番に誕生して5番が生存維持になる
ループなしだと全滅
1ターンに9回もコピペを繰り返しているのが遅くなっている原因かなあ
探査用のシートを使わないで配列変数を使えば少し早くなるはずなんだけど
ほとんど書き直すことになっちゃうなあ
コード全部
'次の世代へ更新
Function NextGeneration() As Long
Application.ScreenUpdating = False
Call CopyAtoB '判定用シート(lifegameB)にコピー
Dim mA As Range
Set mA = Range("mapA")
Dim cc As Long, rc As Long, lifeCount As Long
rc = mA.Rows.Count
cc = mA.Columns.Count
Dim lifeLower As Long, lifeUpper As Long, lifeBirth As Long
lifeLower = Range("下限").Value
lifeUpper = Range("上限").Value
lifeBirth = Range("誕生").Value
Dim ci As Long 'colorIndex
Dim sr As Long 'searchResult
' Dim ti As Single, tc As Single '処理時間計測用
' ti = Timer
For x = 1 To rc
For y = 1 To cc
Dim rA As Range, rB As Range
Set rA = Range("mapA").Cells(x, y)
Set rB = Range("mapB").Cells(x, y)
ci = rB.Interior.ColorIndex
sr = SearchCell(rB) '周囲のセルを探査
' If ci = xlColorIndexNone And sr = lifeBirth Then
' '周囲の生存セル数が3なら誕生
' 'ra.Interior.ColorIndex = 1
' Call NuriBlack(ra)
' lifeCount = lifeCount + 1
' ElseIf ci = 1 And (sr >= lifeLower And sr <= lifeUpper) Then
' '周囲の生存セル数が2か3なら生存
' 'ra.Interior.ColorIndex = 1
' Call NuriBlack(ra)
' lifeCount = lifeCount + 1
' Else
' '上記以外なら消滅
' ra.Interior.ColorIndex = xlColorIndexNone
' End If
'↑0.13秒、↓0.10秒
If ci = xlColorIndexNone Then
'塗りつぶしなしのセルの場合
If sr = lifeBirth Then
lifeCount = lifeCount + 1
rA.Interior.ColorIndex = 1 '黒塗り
' rA.Interior.Color = RGB(255, 0, 0) '赤塗
'Call Nuri2(ra, rb)
End If
Else
'色付きセルの場合
If (sr >= lifeLower And sr <= lifeUpper) Then
lifeCount = lifeCount + 1
Call Nuri2(rA, rB) '塗る
' rA.Interior.ColorIndex = 1 '黒塗り
' rA.Interior.Color = RGB(255, 0, 0)
Else
rA.Interior.ColorIndex = xlColorIndexNone '消滅
rB.Value = 0
End If
End If
Next y
Next
' tc = Timer - ti
' Debug.Print (tc)
NextGeneration = lifeCount
Application.ScreenUpdating = True
End Function
Sub NuriBlack(r As Range)
r.Interior.ColorIndex = 1
End Sub
Sub Nuri2(rA As Range, rB As Range)
rB.Value = rB.Value + 64
If rB.Value > 255 Then rB.Value = 255
rA.Interior.Color = rB.Value
End Sub
'周りの8セルを探査、色付きのセルの個数を返す
Function SearchCell(r As Range) As Long
Dim c As Long
For y = -1 To 1
For x = -1 To 1
If r.Offset(x, y).Interior.ColorIndex <> xlColorIndexNone Then
If Not (x = 0 And y = 0) Then '自身はカウントしない
c = c + 1
End If
End If
Next
Next
SearchCell = c
End Function
Sub initial初期配置()
Dim r As Range
Set r = Range("mapA")
r.Interior.ColorIndex = xlColorIndexNone
Dim rr As Range
For Each rr In r
Randomize
If Rnd < Range("liferacio").Value Then '0.2なら約2割のセルを黒で塗る
rr.Interior.ColorIndex = 1
End If
Next
Range("lifecount").Value = GetLifeCount生存数カウント
Range("mapB").ClearContents 'mapBの数値クリア
End Sub
'生存数カウント
Function GetLifeCount生存数カウント() As Long
Dim r As Range
Dim life As Long
For Each r In Range("mapA")
If r.Interior.ColorIndex <> xlColorIndexNone Then
life = life + 1
End If
Next
GetLifeCount生存数カウント = life
End Function
'全セル塗りつぶしなし
Sub ClearColor()
Worksheets("lifegameA").Activate
Range("mapA").Interior.ColorIndex = xlColorIndexNone
Range("mapB").ClearContents
End Sub
'mapAからmapBへコピペ、上下左右ループ対応
Sub CopyAtoB()
'判定用シート(lifegameB)に書式だけコピー
'Range("mapA").Copy Range("mapB")
Range("mapA").Copy
Range("mapB").PasteSpecial xlPasteFormats
Dim r As Range, rr As Range
Set r = Range("mapB")
Dim rc As Long, cc As Long
rc = r.Rows.Count
cc = r.Columns.Count
'4辺を反対側の外側にコピペ
'1行目を最終行+1行目にコピペ
r.Rows(1).Copy r.Rows(rc + 1)
'最終行を0行目にコピペ
r.Rows(rc).Copy r.Rows(0)
'1列目を最終列+1列目にコピペ
r.Columns(1).Copy r.Columns(cc + 1)
'最終列を0列目にコピペ
r.Columns(cc).Copy r.Columns(0)
'四隅を対角線反対側の外にコピペ
r.Cells(1, 1).Copy r.Cells(rc + 1, cc + 1) '左上を右下に
Set rr = r.Cells(1, 1).Offset(-1, -1)
r.Cells(rc, cc).Copy rr '右下を左上に
Set rr = r.Cells(rc, 1).Offset(1, -1)
r.Cells(1, cc).Copy rr '右上を左下に
Set rr = r.Cells(1, cc).Offset(-1, 1)
r.Cells(rc, 1).Copy rr '左下を右上に
End Sub
'マップの範囲変更、選択範囲をライフゲームの範囲にする
Sub ChangeMapRangeマップの範囲変更()
If TypeName(Selection) <> "Range" Then Exit Sub
If Selection.Areas.Count > 1 Then
MsgBox "複数の選択範囲は選べない"
Exit Sub
End If
If MsgBox("選択範囲をライフゲームの範囲に変更します", vbYesNo) = vbYes Then
Dim rA As Range, rB As Range
'mapA
Set rA = Range("mapA")
rA.ClearFormats '古い範囲の書式をクリア
'範囲の変更と新しい範囲に枠線
Set rA = Selection
rA.Name = "mapA"
rA.Borders.Color = RGB(200, 200, 200) '灰色罫線
rA.BorderAround , xlThin, 3 '赤枠
Worksheets("lifegameA").Calculate
'mapB
Set rB = Range("mapB")
Set rB = rB.Offset(-1, -1)
Set rB = rB.Resize(rB.Rows.Count + 2, rB.Columns.Count + 2)
rB.Clear
Worksheets("lifegameB").Range(rA.Address).Name = "mapB"
Set rB = Range("mapB")
rB.BorderAround , xlThin
End If
End Sub
'指定回数NextGeneration関数をループ
Sub AutoNext()
Dim t As Long
t = Range("ターン数").Value
Dim lifeArray() As Long 'ターン毎の生存数カウント
ReDim lifeArray(t)
lifeArray(0) = GetLifeCount生存数カウント
Dim ti As String
ti = Range("ターン間隔").Value
Dim lifeC As Long
For i = 0 To t - 1
lifeC = NextGeneration '次世代へ進める
Range("nowtrun").Value = i + 1 '現在ターン表示更新
Range("lifecount").Value = lifeC '生存数表示更新
lifeArray(i + 1) = lifeC '生存数を配列に
If lifeC = 0 Then Exit For '生存数0(全滅)ならループを抜ける
'表示更新間隔
'Application.Wait (Now + TimeValue("0:0:1")) '1秒単位
If ti = "最速" Then
Application.Wait [now() + "0:00:00.01"] 'ミリ秒単位
ElseIf ti = "0.1秒" Then
Application.Wait [now() + "0:00:00.1"] 'ミリ秒単位
ElseIf ti = "0.5秒" Then
Application.Wait [now() + "0:00:00.5"]
ElseIf ti = "1秒" Then
Application.Wait [now() + "0:00:01"]
Else
Application.Wait [now() + "0:00:00.5"]
End If
DoEvents 'これがないと画面の更新がされない
Next
'グラフの更新
Call ChangeChart(lifeArray)
End Sub
'2 次元配列の行列を入れ替える: やむえむのExcel VBAメモ
'グラフの更新、すべてのターン終了後にまとめて更新
Sub ChangeChart(Lifes() As Long)
Range("lifelog").Offset(1, 0).ClearContents
Dim lc As Long
lc = UBound(Lifes)
'密度density、配列に入れる
Dim cc As Long
cc = Range("mapA").Cells.Count
Dim Density() As Single, Density2 As Variant
ReDim Density(lc)
For j = 0 To UBound(Density)
Density(j) = Lifes(j) / cc
Next
'配列をそのまま貼り付けると横になる
'縦に貼り付けたいのでワークシート関数のTransposeで縦横入れ替える
Dim Lifes2 As Variant
Lifes2 = Application.WorksheetFunction.Transpose(Lifes)
'生存数をシートに貼付け
Dim r As Range
Set r = Range("lifelog").Resize(lc + 1, 1).Offset(1, 1)
r.Value = Lifes2
'密度も縦横を入れ替えてから貼り付け
Dim rr As Range
Set rr = r.Offset(0, -1)
Density2 = Application.WorksheetFunction.Transpose(Density)
rr.Value = Density2
'シートを再計算してグラフの表示を更新
ActiveSheet.Calculate
End Sub
ボタンとマクロの対応
名前を付けたセル範囲
こういう一覧を作るマクロが
↓
'名前の付いたセル範囲の一覧作成
'アクティブセルを基準に書き込む
Sub rangeName()
Dim n As Names
Set n = ActiveWorkbook.Names
Dim v() As Variant
ReDim v(n.Count, 1)
v(0, 1) = "参照範囲"
v(0, 0) = "名前"
Dim str As String
For i = 1 To n.Count
str = n.Item(i).Value
str = Right(str, Len(str) - 1)
v(i, 1) = str ' n.Item(i).Value
v(i, 0) = n.Item(i).Name
Next
ActiveCell.Resize(UBound(v) + 1, 2).Select
If MsgBox("選択範囲に書き込んでもいい？", vbYesNo) = vbNo Then Exit Sub
Selection.Value = v
End Sub
続き
エクセルVBAでライフゲームその3 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
http://blogs.yahoo.co.jp/gogowaten/14611521.html