Excel VBAでワークシート上に迷路を自動生成するマクロ

くだらないExcelマクロを作るのが些細な趣味なのですが、この前軽い気持ちで作った「迷路を自動で生成して自動で正答ルートを色付けする」というマクロをTwitterで投稿したところ軽くバズりびっくりしました。せっかくなので、ここではその方法を紹介します。今回はまず「自動生成」のほうを紹介します。ソースコードは最後にあります。

「迷路を自動で生成して自動で正答ルートを色付けする」とは

まず、このマクロが何であるのかは、以下のツイート内の動画を見てもらえればわかると思います。

激しい試行錯誤の末、セルと罫で作られたエクセル迷路の正解ルートを自動で描画する、最高にどうでもいいマクロが完成しました。

#Excel　#VBA　 #マクロ pic.twitter.com/iuvtYneYrR

— （有） (@tdyu05) 2019年4月24日

これは、Exceのセルを通路に、罫線を壁に見立てて、ランダムなルートの迷路を描画するマクロと、その迷路の正解ルートを自動で探索し描画するマクロの2つを実行したものです。

迷路を自動生成するアルゴリズム

決して大したものではないのですが、このツイートがバズったために「どうやって生成しているのか気になる」という類のコメントや、エンジニアや競技プログラミングをやられていると思わしき方からも「どんなアルゴリズムなのか」というコメントがちらほら寄せられました。

正直なところ、非プログラマーである私はアルゴリズムをまったく知らず、実際に皆様のコメントを見てから初めて、迷路生成／迷路解答アルゴリズムが存在するのだということを知ったくらいです。ですので、結局どの手法を使っているかわかりません。

生成のロジックは、おそらくいろんな方々が想像されるよりもかなりシンプルな仕組みです。以下の通りです。

（1）真っ白な10マス×10マスのセルを用意する
（2）開始地点として、一番左上のセルに通路を描画する
（3）現在地のセルの四方に通路ができているか否かを確認して、通路ができていない方向をランダムに選択しそのセルに通路を描画
（4）上記の(3)の処理を、四方が通路に囲まれて行き止まりになるか、またはゴールのセルの1つ手前に達するまで再帰処理でループさせる

まず、ここまでを動画にすると以下になります。イメージがつかみやすいでしょうか？

以下、続きです。
（5）既存の通路から新たに別の通路を開通させて上記の（3）～（4）の処理を再度行う
（6）上記(3)～(5)を繰り返し、10マス×10マスのセルをすべて埋めたら再帰処理のループを抜けて終了
（7）左上のセルの上部の罫線と右下のセルの下部の罫線を消して入り口出口を開通

以上です。アルゴリズムとしてはたったこれだけです。
ただ、非プログラマーの私としてはこれをどうやってExcelやVBAの中で実装するかが大変でした。（結果、ものすごく膨大な時間がかかってしまいました…）行数もたかだか220行程度です。本職の方がやればすぐ終わると思います。

Excel VBAで実装する方法

では、実際にVBAでどう作ったのかをポイントを紹介します。ソースコードについては、最後にすべて記すのでそちらを参照してください。まず先ほどの
「（3）現在地のセルの四方に通路ができているか否かを確認して、通路ができていない方向からランダムな方向を選択しそのセルを描画」の部分にふれてみます。

描画する前に、まず隣のセルに通路があるかを確認する方法

通路の判定はセル上のプロパティで行っていません。まず10×10のセルを２次元配列とみなし、配列変数にし、変数上で判定を行っています。デフォルトでは各座標の要素に0の値を入れておき、通路ができたらその座標の値を1にフラグオンします。
つまり、現在地の座標を基準に上下左右隣の座標が0ならその道を開通させる、というロジックです。

２次元配列の初期化

上述の２次元配列を初期化するためには次の記述を行います。下記の赤がy座標（＝行）であり、青がx座標（＝列）です。

arr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
arr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
Dim i As Integer
   For i = 1 To 10
      arr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
   Next i

上記を見ると要素数はy座標12マス×x座標12マスとなっています。迷路のマスは10マス×10マスなので疑問に思うかもしれませんが、その理由は次の画像の通りです。2次元配列をセル上に可視化してみました。

あるセルから四方の配列要素の値が0か1かを判断するというロジックを使うといっても、壁側のセルの場合、壁の外を探索する必要ないので四方を調べる処理が使えません。しかし壁側セルだけに別の処理を書かせるとコードかなり煩雑になるので、壁側の外側にもy,x座標のマスを設けているのです。

隣のセルに通路を描画する

隣のセルに通路を描写するのは、後述のソースコード内に記載したfillRouteというプロシージャで行います。ただし、単純に道＋壁を塗る処理だと以下のようになってしまうので、壁を開通させながら進まなければいけません。

進んだ方向からの壁を開通させるには、セルから次に進む方向を決めた後、自分がもともといた方向の数値を引数に取ってfillRouteプロシージャを呼び出します（ソースコード中「'//次に進む方向を決定」のコメント以下を参照）。進む方向と数字の対応は以下の通りです。
１：上方向
２：右方向
３：下方向
４：左方向

次に進んだ方向がわかれば自分がもともといた場所もわかります。

隣のセルに通路を描画する再起処理を止める条件は？

先ほどのステップ（4）で「四方が通路に囲まれて行き止まりになるか、またはゴールのセルの1つ手前に達するまで再帰処理でループさせる」という書きました。後者は例えば次の画像を見てください（ゴールのセルはK11。その手前のK10に来たのでストップしている）

（※今書いていて思い始めましたが、ゴールセル手前まで到達したら再起をストップという処理は迷路生成ロジックそのものとしては不要だったなと思い始める。別に手前まで止めずとともゴールセル上をそのまま描画しても多分迷路は作れますね・・）

行き止まり到達後、新たなセルから再び通路描画を始める

行き止まりに達したあと、次は任意のセルからまた通路生成を開始します。開始するセルを選ぶ処理は、正直妥協しました・・次に開通するセルは、「まだ通路が描画されていないセルを左上から検索していき最初にヒットした場所にする」という単純な条件で選択しています。先程の図でいうとH2のセルです（下図参照）

新たな通路描画の開始セルと既存の通路を開通させる

当然ですが、新たに生成した通路は既存の通路と開通させる必要があります。上記の画面でいえば、H2セルから始まった場合、G2セル側か、H3セル側の壁を開通させます。ソースコードを見てもらえればと思いますが、ここでは開通のために以下の処理をしています。
（1）配列direction()に壁がある方向の番号を格納
（2）関数getDirectionNumで、(1)で見つかった壁のうちどこに穴を開けるか、壁の方向(の番号)をランダムで取得
（3）その後、(２)で取得した開通先を引数に、最初に述べたfillRouteプロシージャで通路描画

これで行き止まりに達したらまた上記（1）～（3）を行います。10マス×10マスの迷路なので、通路を描画したセルが100個に到達したらExit Subしてマクロを終了します。

作ってみての感想

いま振り返りながら文書化してみると、もう少しシンプルに書けたり改良したりできたなと思うところはあります。特に行き止まりに達したあと、本来であれば新たに通路描画を開始するセルは以下の数だけ存在します（＝既存の通路と接しているところ）

なので、「ランダムなx、y座標を生成させて、それが水色の部分に該当したらそこから描画を始める」という処理でもよかったかもしれません。

最後に1ステップずつ迷路を描画するGIF動画を置いておきます。今回迷路生成ロジックを説明しましたが、迷路を解くマクロは感覚的にその倍くらい苦労しました。これは次回解説します。

 ソースコード

以下、今回の迷路生成マクロのソースコードです。多分標準モジュールにこのままコピペすれば使えるはずです。

Dim mazeArea As Range
Dim currentPosition As Range
Dim x As Integer, y As Integer
Dim cnt As Integer
Dim arr(11) As Variant
Const limit = 4
Sub initializing()
Application.ScreenUpdating = False
 
 '//埋まったセルの数を数えるをカウンタ
cnt = 0

'//迷路の範囲を定義&初期化
Set mazeArea = Range(Cells(2, 2), Cells(11, 11))
mazeArea.Clear

'//マスが埋まっているかいないかを1か0で判定するための配列を初期化
arr(0) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
arr(11) = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
Dim i As Integer
For i = 1 To 10
    arr(i) = Array(1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1)
Next i

'//自分の最初の座標
x = 1
y = 1

'//道の描画（今いるセルに色と罫をつける）
Call fillRoute(1)

'//次に描画する道（セル）に移動
Call move

End Sub
Sub move()
Dim up As Integer, rt As Integer, bt As Integer, lf As Integer
Dim sum1 As Integer, sum2 As Integer
Dim a As Integer
Dim b As Integer
Dim n As Integer
Dim direction() As Integer
Dim directionArray As Variant
Dim xx As Integer

Randomize

'//セルを100個塗ったら作成終了
If cnt > 99 Then
    mazeArea.Cells(1, 1).Borders(xlEdgeTop).LineStyle = xlNone
    mazeArea.Cells(10, 10).Borders(xlEdgeBottom).LineStyle = xlNone
    Application.ScreenUpdating = True
    Exit Sub
End If

'//隣のセルに移動できるかどうかを判定
up = arr(y - 1)(x)
bt = arr(y + 1)(x)
rt = arr(y)(x + 1)
lf = arr(y)(x - 1)
sum1 = up + bt + rt + lf
                
'//もし隣のセルがすべて埋まっていてこれ以上進めない場合、
'//あるいは、ゴールセルの1つ手前のセルに初めて来た場合に
'//新たな空白セルからスタート＋任意の方向の壁を開通
If (sum1 = limit) Or (((y = 9 And x = 10) Or (y = 10 And x = 9)) And stopFlg = False) Then
    If (y = 9 And x = 10) Or (y = 10 And x = 9) Then stopFlg = True
    Dim i As Integer, j As Integer
    For i = 1 To 10
        For j = 1 To 10
            If arr(i)(j) = 0 Then
                up = arr(i - 1)(j)
                bt = arr(i + 1)(j)
                rt = arr(i)(j + 1)
                lf = arr(i)(j - 1)
                '//現在地セルの周りが何方向埋まっているかの数を格納
                sum2 = up + bt + rt + lf
                
                '//埋まっている方向（の番号）を配列に入れる
                ReDim direction(sum2 - 1) As Integer
                xx = 0
                If up = 1 Then
                    direction(xx) = 3 '//上方向が埋まってる場合
                    xx = xx + 1
                End If
                If bt = 1 Then
                    direction(xx) = 1  '//下方向が埋まってる場合
                    xx = xx + 1
                End If
                If rt = 1 Then
                    direction(xx) = 4 '//右方向が埋まってる場合
                    xx = xx + 1
                End If
                If lf = 1 Then
                    direction(xx) = 2 '//左方向が埋まってる場合
                End If
                
                y = i
                x = j
                Select Case sum2
                    Case 1
                        fillRoute (direction(xx))
                    Case 2
                        directionArray = Array(direction(0), direction(1))
                    Case 3
                        directionArray = Array(direction(0), direction(1), direction(2))
                    Case 4
                        directionArray = Array(direction(0), direction(1), direction(2), direction(3))
                End Select
                '//壁を開通させる方向を取得する関数
                num = getDirectionNum(directionArray, sum2)
                '//次の道を描画
                fillRoute (num)
                
                If Not cnt > 99 Then Call move
                Exit For
            End If
        Next j
    Next i
    
End If


'//次に進む方向を決定
n = Int(Rnd * 4) + 1
Select Case n
    Case 1 '//上
        '//もし移動先が進めないセルだったら進む方向は決定せず再帰
        If y = 1 Or arr(y - 1)(x) = 1 Then
            Call move
            Exit Sub
        Else
            a = -1
            b = 0
        End If
    Case 2 '//右
        If x = 10 Or arr(y)(x + 1) = 1 Then
            Call move
            Exit Sub
        Else
            a = 0
            b = 1
        End If
    Case 3 '//下
        If y = 10 Or arr(y + 1)(x) = 1 Then
            Call move
            Exit Sub
        Else
            a = 1
            b = 0
        End If
    Case 4 '//左
        If x = 1 Or arr(y)(x - 1) = 1 Then
            Call move
            Exit Sub
        Else
            a = 0
            b = -1
        End If
End Select

'//次の道の座標
y = y + a
x = x + b

'//次の道を描画
Call fillRoute(n)
'//Application.Wait [Now() + "0:00:00.1"] '//デバッグ用。描画の様子を1マスずつ確認するため

Call move

End Sub
Sub fillRoute(num As Integer)
    Set currentPosition = mazeArea.Cells(y, x)
    With currentPosition
        .BorderAround Weight:=xlThick, LineStyle:=xlContinuous
        Select Case num
            Case 1
                .Borders(xlEdgeBottom).LineStyle = xlNone
            Case 2
                .Borders(xlEdgeLeft).LineStyle = xlNone
            Case 3
                .Borders(xlEdgeTop).LineStyle = xlNone
            Case 4
                .Borders(xlEdgeRight).LineStyle = xlNone
        End Select
        .Interior.ColorIndex = xlAutomatic
        .Interior.Pattern = xlCrissCross
        .Interior.PatternThemeColor = xlThemeColorAccent4
        .Interior.PatternTintAndShade = 0.6
    End With
    '//描画済みの座標をフラグオン
    arr(y)(x) = 1
    cnt = cnt + 1
End Sub
Function getDirectionNum(ByVal directionArray_ As Variant, sum2_ As Integer) As Integer
'/*壁を開通する方向を決定する関数*/

Dim n As Integer, directionNum As Integer, flg As Boolean
    Randomize
    Do
        n = Int(Rnd * sum2_)
        directionNum = directionArray_(n)
        If y = 1 And directionNum = 3 Then
            flg = True
        ElseIf y = 10 And directionNum = 1 Then
            flg = True
        ElseIf x = 1 And directionNum = 2 Then
            flg = True
        ElseIf x = 10 And directionNum = 4 Then
            flg = True
        Else
            flg = False
        End If
    Loop While flg = True
    getDirectionNum = directionNum
End Function