エクセルVBAでライフゲームその2のコードと名前の付いたセル範囲の一覧作成マクロ

前回の記事

gogowaten.hatenablog.com

エクセルVBAでライフゲームその2 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
http://blogs.yahoo.co.jp/gogowaten/14606097.html

の補足

上下左右ループ

前々回

http://www.geocities.jp/gogowaten/lifegame10.gif

前々回ではループさせていなかったので端に行くと消えたり詰まったりしていた

前回

http://www.geocities.jp/gogowaten/lifegame11.gif

前回でループするようにした

赤枠が全体マップ

黒枠が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メモ
'http://yumem.cocolog-nifty.com/excelvba/2011/03/2-fb9c.html

'グラフの更新、すべてのターン終了後にまとめて更新
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

ボタンとマクロの対応

f:id:gogowaten:20191030133836p:plain

名前を付けたセル範囲

こういう一覧を作るマクロが

↓

'名前の付いたセル範囲の一覧作成
'アクティブセルを基準に書き込む
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