【VBA】迷路を解く
概要
今回はPythonで習ったアルゴリズムをVBAに使用して迷路を解いてみたいと思います。
迷路ってどうやって解くの?
数年前の話ですが、転職するときにプログラミングの試験がありました。
そのときに出題された問題の中で「平面上の迷路のスタートからゴールまでの経路を表示してください」
という問題がありました。
アルゴリズムを使用すれば解ける問題だったのですが、当時のわたしはアルゴリズムについて知らなかったので
問題に全く歯が立ちませんでした。
ここ1~2年でPythonでアルゴリズムを勉強する機会に恵まれ
とあるアルゴリズムを使用すると簡単に迷路を解けることが分かりました。
幅優先探索を使うと迷路を解ける
アルゴリズムの中で幅優先探索というものがあります。
幅優先探索(はばゆうせんたんさく、英: breadth first search)はグラフ理論(Graph theory)において木構造(tree structure)やグラフ(graph)の探索に用いられるアルゴリズム。
アルゴリズムは根ノードで始まり隣接した全てのノードを探索する。
それからこれらの最も近いノードのそれぞれに対して同様のことを繰り返して探索対象ノードをみつける。
「横型探索」とも言われる。
出典:Wikipedia 幅優先探索
スタート地点から、隣り合う地点をどんどん検索していき最終的にゴールを見つけるようなイメージです。
幅優先探索を迷路問題に適用すると、簡単に迷路を解くことができたのでそのスゴさにびっくりしました。
キュー(Queue)がない・・・
幅優先探索ではキュー(Queue)というデータ構造を使用します。
Pythonだとdequeがあるのですが、VBAにはキューがありません。
VBAのクラスモジュールの練習のため、以前キューをクラスとして実装しました。
こちらのキュークラスを使用して、迷路を解いてみます。
https://kazusa-pg.com/vba-queue/
迷路をVBAで解いてみる
Mazeという名前のシートを作成しセルに文字入力したものを迷路とみなします。

シート上の各文字の意味は以下になります。
記号 | 内容 |
---|---|
S | スタート位置です |
G | ゴール位置です |
空白 | 通ることができます |
# | 壁なので通ることができません |
幅優先探索で迷路を解くコードは以下になります。
1Option Explicit
2
3Dim maze() As String
4Dim visited() As Boolean
5Dim goalFlag As Boolean
6Dim prevCoordinate() As Collection
7Sub solveMaze()
8
9 Dim mazeSht As Worksheet
10 Set mazeSht = ThisWorkbook.Worksheets("Maze")
11
12 Dim lastRow As Long
13 Dim lastCol As Long
14
15 lastRow = getMaxRow(mazeSht, 1) - 1
16 lastCol = getMaxCol(mazeSht, 1) - 1
17
18 mazeSht.Range(mazeSht.Cells(1, 1), mazeSht.Cells(lastRow, lastCol)).Interior.ColorIndex = -4142
19
20 ReDim maze(lastRow, lastCol) '迷路全体を格納する2次元配列
21 ReDim visited(lastRow, lastCol) '迷路でそのセルを既に訪れたか確認するための2次元配列
22 ReDim prevCoordinate(lastRow, lastCol) '迷路でどのセルから到達したかを保存しておくための2次元配列
23 '正解の経路を割り出すために使用する
24
25 '迷路のデータをmaze配列に格納し
26 'visited配列とprevCoordinateを初期化する
27 Dim i As Long
28 Dim j As Long
29 For i = 0 To lastRow
30 For j = 0 To lastCol
31 maze(i, j) = mazeSht.Cells(i + 1, j + 1)
32 visited(i, j) = False
33 'prevCoordinateにはY座標-1、X座標-1のCollection型を初期値として格納する
34 Dim prevYx As Collection
35 Set prevYx = New Collection
36 prevYx.Add -1, "Y"
37 prevYx.Add -1, "X"
38 Set prevCoordinate(i, j) = prevYx
39 Next j
40 Next i
41
42 'スタート位置のy座標とx座標を抽出
43 Dim pos() As Long
44 Dim startYx As Collection
45 pos = findChar(maze, "S", lastRow, lastCol)
46 If pos(0) = -1 And pos(1) = -1 Then
47 MsgBox "迷路からスタート位置を見つけることができませんでした。" & vbNewLine & _
48 "迷路に大文字のSが入力されているか確認してください。" & vbNewLine & _
49 "処理を中止します。", vbCritical, "スタート位置が見つかりませんでした"
50 GoTo Finally
51 End If
52 Set startYx = New Collection
53 startYx.Add pos(0), "Y"
54 startYx.Add pos(1), "X"
55
56 'ゴール位置のy座標とx座標を抽出
57 Erase pos
58 Dim goalYx As Collection
59 pos = findChar(maze, "G", lastRow, lastCol)
60 If pos(0) = -1 And pos(1) = -1 Then
61 MsgBox "迷路からゴール位置を見つけることができませんでした。" & vbNewLine & _
62 "迷路に大文字のGが入力されているか確認してください。" & vbNewLine & _
63 "処理を中止します。", vbCritical, "ゴール位置が見つかりませんでした"
64 GoTo Finally
65 End If
66 Set goalYx = New Collection
67 goalYx.Add pos(0), "Y"
68 goalYx.Add pos(1), "X"
69
70 goalFlag = False
71
72 '幅優先探索のためキューを使用する
73 Dim q As Queue
74 Set q = New Queue
75 q.enqueue startYx
76 Do While q.count > 0 And goalFlag = False
77 '幅優先探索で探索を開始
78 Call bfs(q, lastRow, lastCol)
79 Loop
80
81 If goalFlag Then
82 Call paintPath(mazeSht, goalYx("Y"), goalYx("X"))
83 MsgBox "ゴールできます!", vbInformation, "探索完了"
84 Else
85 MsgBox "ゴールできません・・・", vbInformation, "探索完了"
86 End If
87
88Finally:
89
90 Set mazeSht = Nothing
91 Set prevYx = Nothing
92 Set startYx = Nothing
93 Set goalYx = Nothing
94 Set q = Nothing
95
96End Sub
97Function findChar(maze() As String, c As String, lastRow As Long, lastCol As Long) As Long()
98 'スタート位置とゴール位置を見つける
99 '配列の0にy座標,配列の1にx座標を格納する
100 '位置が見つからない場合はpos(0)とpos(1)に
101 '-1を格納した配列を戻す
102
103 Dim i As Long
104 Dim j As Long
105 Dim pos(1) As Long
106
107 For i = 0 To lastRow
108 For j = 0 To lastCol
109 If maze(i, j) = c Then
110 pos(0) = i
111 pos(1) = j
112 findChar = pos
113 Exit Function
114 End If
115 Next j
116 Next i
117
118 pos(0) = -1
119 pos(1) = -1
120 findChar = pos
121
122End Function
123Function bfs(q As Queue, lastRow As Long, lastCol As Long) As Variant
124 '幅優先探索を行う
125
126 Dim mY(3) As Long
127 Dim mX(3) As Long
128
129 'mYとmXの配列を組み合わせて、現在のセルの位置から上、下、左、右の
130 'セルを探索する
131 mY(0) = -1
132 mY(1) = 1
133 mY(2) = 0
134 mY(3) = 0
135
136 mX(0) = 0
137 mX(1) = 0
138 mX(2) = -1
139 mX(3) = 1
140
141 Dim currentYx As Collection
142 Set currentYx = New Collection
143 Set currentYx = q.dequeue
144
145 Dim currentY As Long
146 Dim currentX As Long
147 currentY = currentYx("Y")
148 currentX = currentYx("X")
149
150 visited(currentY, currentX) = True
151 'Debug.Print currentY & " " & currentX
152
153 Dim i As Long
154 For i = 0 To UBound(mY)
155 Dim ny As Long
156 Dim nx As Long
157 ny = currentY + mY(i)
158 nx = currentX + mX(i)
159 If ny < 0 Or lastRow < ny Or _
160 nx < 0 Or lastCol < nx Then '枠からはみ出る場合は次のセルを探索
161 GoTo NextFor
162 End If
163 If visited(ny, nx) Then '既に訪れている場所は次のセルを探索
164 GoTo NextFor
165 End If
166 If maze(ny, nx) = "#" Then '壁の場合は移動できないので次のセルを探索
167 GoTo NextFor
168 End If
169 'どの座標から到達したか保存しておく。スタートからゴールまでの経路表示に使用。
170 Dim prevYx As Collection
171 Set prevYx = New Collection
172 prevYx.Add currentY, "Y"
173 prevYx.Add currentX, "X"
174 Set prevCoordinate(ny, nx) = prevYx
175
176 '探索しているセルがゴールなら幅優先探索を終了
177 If maze(ny, nx) = "G" Then
178 goalFlag = True
179 Exit Function
180 End If
181
182 Dim nextYx As Collection
183 Set nextYx = New Collection
184 nextYx.Add ny, "Y"
185 nextYx.Add nx, "X"
186 Call q.enqueue(nextYx)
187
188NextFor:
189 Next i
190
191 Set currentYx = Nothing
192 Set prevYx = Nothing
193 Set nextYx = Nothing
194
195End Function
196Sub paintPath(mazeSht As Worksheet, y As Long, x As Long)
197 '正解の経路のセルを緑色にする
198
199 Do While prevCoordinate(y, x)("Y") <> -1 And _
200 prevCoordinate(y, x)("X") <> -1
201 mazeSht.Cells(y + 1, x + 1).Interior.ColorIndex = 50
202 Dim tmpY As Long
203 Dim tmpX As Long
204 tmpY = y
205 tmpX = x
206 y = prevCoordinate(tmpY, tmpX)("Y")
207 x = prevCoordinate(tmpY, tmpX)("X")
208 Loop
209 mazeSht.Cells(y + 1, x + 1).Interior.ColorIndex = 50
210
211End Sub
212Function getMaxRow(sht As Worksheet, targetCol As Long) As Long
213
214 getMaxRow = sht.Cells(sht.Rows.count, targetCol).End(xlUp).Row
215
216End Function
217Function getMaxCol(sht As Worksheet, targetRow As Long) As Long
218
219 getMaxCol = sht.Cells(targetRow, sht.Columns.count).End(xlToLeft).Column
220
221End Function
キュークラスをクラスモジュールに貼り付けます。
https://kazusa-pg.com/vba-queue/
最終行と最終列を取得するためにgetMaxRowとgetMaxColを使用してます。
https://kazusa-pg.com/vba-get-max-row-column-number/
現在できること
- 長方形、正方形の迷路を解くことができる
- スタートからゴールまでの正解の経路を算出する
- ゴールできない場合は「ゴールできません」と表示する
コードを動かしてみる
下記のような9×9の迷路をシートに入力してみます。
「迷路を解く」ボタンを押すとsolveMazeサブプロシージャを実行します。

ボタンを押して迷路を解いてみます。
ゴールできる場合は、「ゴールできます」とメッセージボックスが表示されます。

そして、スタートからゴールまでの経路を緑色で表示します。

ゴールに到達できない迷路を用意します。

ボタンを押してプログラムを動かすとゴールに到達できないので「ゴールできません」とメッセージボックスに表示されます。

迷路の自動生成
2018/8/9追記
迷路を自動で生成する記事を書きました。