1Option Explicit
  2Sub createMaze()
  3  
  4  Dim sizeStr As String
  5  
  6  sizeStr = InputBox("5以上99以下の奇数を入力してください")
  7  If sizeStr = "" Then Exit Sub
  8  
  9  If checkInputNumber(sizeStr) = False Then Exit Sub
 10  
 11  Dim msgboxVal As Long
 12  Dim displayFlag As Boolean
 13  msgboxVal = MsgBox("迷路作成の途中経過を表示しますか？", vbYesNo + vbQuestion, "確認")
 14  If msgboxVal = vbYes Then
 15    displayFlag = True
 16  Else
 17    displayFlag = False
 18    Application.ScreenUpdating = False
 19  End If
 20  
 21  Dim size As Long
 22  size = CLng(sizeStr)
 23  
 24  size = size - 1 '配列数を奇数にする
 25  Dim maze() As String
 26  ReDim maze(size, size)
 27  
 28  Dim mazeSht As Worksheet
 29  Set mazeSht = ThisWorkbook.Worksheets("maze")
 30  mazeSht.UsedRange.Clear
 31  
 32  Dim i As Long
 33  Dim j As Long
 34    
 35  '外周以外を壁に設定
 36  For i = 1 To size - 1
 37    For j = 1 To size - 1
 38      maze(i, j) = "#"
 39    Next j
 40  Next i
 41  mazeSht.Activate
 42  If displayFlag Then Call displayMaze(maze, size)
 43  
 44  Dim y As Long
 45  Dim x As Long
 46  y = getOdd(size)
 47  x = getOdd(size)
 48  maze(y, x) = "" '探索スタート地点を通路に変更
 49  Call digMaze(maze, y, x, size, displayFlag)
 50  
 51  '外周を壁に設定する
 52  For i = 0 To size
 53    For j = 0 To size
 54      If i = 0 Or i = size Or j = 0 Or j = size Then
 55        maze(i, j) = "#"
 56      End If
 57    Next j
 58  Next i
 59  
 60  Call displayMaze(maze, size)
 61  mazeSht.UsedRange.Columns.AutoFit
 62  
 63  Application.ScreenUpdating = True
 64  MsgBox "迷路を作成しました", vbInformation, "迷路作成完了"
 65  
 66End Sub
 67Function checkInputNumber(sizeStr As String) As Boolean
 68  'インプットボックスに入力された数値のチェック
 69  
 70  If IsNumeric(sizeStr) = False Then
 71    MsgBox "数値を入力してください", vbCritical, "数値以外が入力されました"
 72    Exit Function
 73  End If
 74  Dim size As Long
 75  size = CLng(sizeStr)
 76  If size Mod 2 = 0 Then
 77    MsgBox "奇数を入力してください", vbCritical, "奇数が入力されました"
 78    Exit Function
 79  End If
 80  If size < 5 And 99 < size Then
 81    MsgBox "5以上99以下の数値を入力してください", vbCritical, "入力値を確認してください"
 82    Exit Function
 83  End If
 84
 85  checkInputNumber = True
 86
 87End Function
 88
 89Function getOdd(size As Long) As Long
 90  
 91  '1以上size未満の奇数を取得する
 92  
 93  Dim v As Long
 94  Do While v Mod 2 = 0
 95    Randomize
 96    v = Int(size * Rnd + 1)
 97  Loop
 98  
 99  getOdd = v
100  
101End Function
102Sub displayMaze(maze() As String, size As Long)
103  '迷路をシートに表示
104  
105  Dim sht As Worksheet
106  Set sht = ThisWorkbook.Worksheets("maze")
107  
108  Dim i As Long
109  Dim j As Long
110  
111  For i = 0 To size
112    For j = 0 To size
113      sht.Cells(i + 1, j + 1) = maze(i, j)
114    Next j
115  Next i
116  
117  Set sht = Nothing
118  DoEvents
119  
120End Sub
121
122Sub digMaze(maze() As String, y As Long, x As Long, _
123            size As Long, displayFlag As Boolean)
124  '穴掘り法による迷路作成
125  Dim directions(3) As String
126  directions(0) = "N"
127  directions(1) = "E"
128  directions(2) = "S"
129  directions(3) = "W"
130  
131  Dim v As Variant
132  v = shuffleAry(directions)
133  
134  Dim i As Long
135  Dim c As Collection
136  For i = 0 To UBound(directions)
137    Dim mY As Long
138    Dim mX As Long
139    If directions(i) = "N" Then
140      mY = y - 2
141      mX = x
142      '座標を北に2つ移動してみる。
143      '移動先の座標が外周内に収まり、かつ通路でなければ
144      '現在の座標から北の座標2つ分を通路にする
145      If checkMazeCell(maze, mY, mX, size) Then
146        maze(y - 1, x) = ""
147        maze(y - 2, x) = ""
148        If displayFlag Then Call displayMaze(maze, size)
149        '移動先の座標で再帰処理
150        Call digMaze(maze, mY, mX, size, displayFlag)
151      End If
152    ElseIf directions(i) = "E" Then
153      mY = y
154      mX = x + 2
155      '座標を東に2つ移動してみる。
156      '移動先の座標が外周内に収まり、かつ通路でなければ
157      '現在の座標から東の座標2つ分を通路にする
158      If checkMazeCell(maze, mY, mX, size) Then
159        maze(y, x + 1) = ""
160        maze(y, x + 2) = ""
161        If displayFlag Then Call displayMaze(maze, size)
162        '移動先の座標で再帰処理
163        Call digMaze(maze, mY, mX, size, displayFlag)
164      End If
165    ElseIf directions(i) = "S" Then
166      mY = y + 2
167      mX = x
168      '座標を南に2つ移動してみる。
169      '移動先の座標が外周内に収まり、かつ通路でなければ
170      '現在の座標から南の座標2つ分を通路にする
171      If checkMazeCell(maze, mY, mX, size) Then
172        maze(y + 1, x) = ""
173        maze(y + 2, x) = ""
174        If displayFlag Then Call displayMaze(maze, size)
175        '移動先の座標で再帰処理
176        Call digMaze(maze, mY, mX, size, displayFlag)
177      End If
178    Else
179      mY = y
180      mX = x - 2
181      '座標を西に2つ移動してみる。
182      '移動先の座標が外周内に収まり、かつ通路でなければ
183      '現在の座標から西の座標2つ分を通路にする
184      If checkMazeCell(maze, mY, mX, size) Then
185        maze(y, x - 1) = ""
186        maze(y, x - 2) = ""
187        If displayFlag Then Call displayMaze(maze, size)
188        '移動先の座標で再帰処理
189        Call digMaze(maze, mY, mX, size, displayFlag)
190      End If
191    End If
192  Next i
193  
194End Sub
195
196Function checkMazeCell(maze() As String, mY As Long, mX As Long, _
197                       size As Long) As Boolean
198  '移動先の座標が配列のサイズに収まり、さらに通路でないことを確認する
199  
200  '移動先のyが配列内に収まるか確認
201  If mY < 0 Or size < mY Then
202    Exit Function
203  End If
204  
205  '移動先のxが配列内に収まるか確認
206  If mX < 0 Or size < mX Then
207    Exit Function
208  End If
209  
210  '移動先の座標が通路かどうか確認する
211  If maze(mY, mX) = "" Then
212    Exit Function
213  End If
214  
215  checkMazeCell = True
216  
217End Function
218
219' 配列をシャッフルする関数
220'http://techoh.net/vba-shuffle-array/
221Function shuffleAry(list() As String)
222    
223  Dim i As Long
224  Dim rn As Long
225  Dim tmp As String
226    
227  For i = 0 To UBound(list)
228    Randomize
229    rn = Int(UBound(list) * Rnd)
230    tmp = list(i)
231    list(i) = list(rn)
232    list(rn) = tmp
233  Next
234    
235  shuffleAry = list
236End Function