あみだくじでスタートからゴールまで辿らせてみる

昨日は、あみだくじの線を自動で作成することに挑戦した。
infoment.hatenablog.com

今日は、これを自動で辿らせてみる。

正しい道を辿るために、今回は、スタート位置を２行２列に拡大してみた。

この拡大領域について、次のように判別する。

1. ①に底線がある ⇒ 左へオフセット
2. ②に底線がある ⇒ 右へオフセット
3. 上記の結果に関わらず、必ず下へオフセット

ついでに、経路に色を付けてみよう。今回は視認しやすさを目的として、拡大した２行２列を選択しながら移動させてみた。

Sub Solution(start_range As Range)
    ' 開始セルを塗りつぶし。
    start_range.Interior.Color = 192

    Dim myRng As Range
    ' 開始セルを２行２列に拡大する。
    ' ※進行方向決定のため。
    Set myRng = start_range.Offset(1).Resize(2, 2)
        myRng.Select
    Dim dx As Long

    Do
        ' 必ず下に降りるので、一つ目の右線に着色。
        myRng.Item(1).Borders(xlEdgeRight).Color = 192
        myRng.Item(1).Borders(xlEdgeRight).Weight = xlMedium
        
        ' ①に底線がある ⇒ 左に動く。
        If myRng.Item(1).Borders(xlEdgeBottom).LineStyle <> xlNone Then
            dx = -1
            myRng.Item(1).Borders(xlEdgeBottom).Color = 192
            myRng.Item(1).Borders(xlEdgeBottom).Weight = xlMedium
        
        ' ②に底線がある ⇒ 右に動く。
        ElseIf myRng.Item(2).Borders(xlEdgeBottom).LineStyle <> xlNone Then
            dx = 1
            myRng.Item(2).Borders(xlEdgeBottom).Color = 192
            myRng.Item(2).Borders(xlEdgeBottom).Weight = xlMedium
        Else
            dx = 0
        End If
        
        ' 左右どちらかに加えて一つ下にオフセット。
        Set myRng = myRng.Offset(1, dx)
        
        myRng.Select
        Application.Wait [Now()+"00:00:01"]

        If myRng.Item(1).Borders(xlEdgeRight).LineStyle = xlNone Then Exit Do
    Loop
    
    ' 終了セルを塗りつぶし。
    myRng.Item(1).Interior.Color = 192
        
End Sub

それでは早速、試してみよう。

Sub test_2()
    Solution Selection
End Sub

あみだくじ～♪と歌いながら画面を眺めれば、楽しさ倍増です。

参考まで。