あみだくじでスタートからゴールまで辿らせてみる
昨日は、あみだくじの線を自動で作成することに挑戦した。
infoment.hatenablog.com
今日は、これを自動で辿らせてみる。
正しい道を辿るために、今回は、スタート位置を2行2列に拡大してみた。
この拡大領域について、次のように判別する。
- ①に底線がある ⇒ 左へオフセット
- ②に底線がある ⇒ 右へオフセット
- 上記の結果に関わらず、必ず下へオフセット
ついでに、経路に色を付けてみよう。今回は視認しやすさを目的として、拡大した2行2列を選択しながら移動させてみた。
Sub Solution(start_range As Range) ' 開始セルを塗りつぶし。 start_range.Interior.Color = 192 Dim myRng As Range ' 開始セルを2行2列に拡大する。 ' ※進行方向決定のため。 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
あみだくじ~♪と歌いながら画面を眺めれば、楽しさ倍増です。
参考まで。