
VBA
Option Explicit
Sub Meikyuu()
' #VBA100本ノック 迷宮編
Dim x As Long, y As Long, ny As Long, nx As Long ' セル位置座標用
Dim Bx As Long, By As Long, Bnx As Long, Bny As Long ' 5×5ブロック単位範囲用
Dim ForY As Long, ForX As Long, ForXS As Long, ForXE As Long, xStep As Long
Dim i As Long, iss As Long, ie As Long, iStep As Long
Dim j As Long, js As Long, je As Long, jStep As Long
Dim Kyori As Double, stKyori As Double ' 直線距離計算用
Dim Flg As Boolean ' 最短距離フラグ
Dim Arr As Variant ' セル値ストック用配列
Range("A1:O15").ClearContents: Range("A1").Select ' シートクリア
x = 1: y = 1 ' スタート位置セット
' 5×5のブロック単位でサーチ
For ForY = 1 To 11 Step 5
' 横位置は左右スタート位置が交互にする設定
If ForY = 6 Then ForXS = 11: ForXE = 1: xStep = -5 Else ForXS = 1: ForXE = 11: xStep = 5
' ブロック単位サーチ
For ForX = ForXS To ForXE Step xStep
' ブロック内左右サーチはプロック左右進行方向に合わせる
If ForY = 6 Then iss = 4: ie = 0: iStep = -1 Else iss = 0: ie = 4: iStep = 1
For Bx = iss To ie Step iStep
' ブロック内上下は前回通過点に近い方からスタートし、交互に上下
If x Mod 5 = 0 Or x Mod 5 = 4 Then js = 4: je = 0: jStep = -1 Else js = 0: je = 4: jStep = 1
For By = js To je Step jStep
If Cells(ForY + By, ForX + Bx).Interior.Color = vbYellow Then
Call Marking(y, x, ForY + By, ForX + Bx) ' ルートマーキング処理へ
y = ForY + By: x = ForX + Bx
End If
Next
Next
Next
Next
Call Marking(y, x, 15, 15) ' 最終黄色地点から終点まで
End Sub
Sub Marking(y As Long, x As Long, ny As Long, nx As Long)
Dim stPos As Long, i As Long, sStep As Long
Dim Flg As Boolean ' 通過で出来ずフラグ
Dim stArr As Variant ' セル値ストック用配列
stArr = Range("A1:O15").Value ' 最初のセル状態ストック
' 【地点間の通過済でないルート探索(縦位置スタートから試み、駄目なら次に横位置スタート)】
Flg = True
' 縦 → 横 探索
' 最初に縦位置探索(既に通過済と交わればフラグOFF)
If y <= ny Then sStep = 1 Else sStep = -1
Cells(y, x).Value = "" ' スタート位置クリア
For i = y To ny Step sStep
If Cells(i, x).Value <> "" Then Flg = False
Cells(i, x).Value = "●"
Next
' 次に横位置探索(既に通過済と交わればフラグOFF)
If x <= nx Then sStep = 1 Else sStep = -1
Cells(ny, x).Value = "" ' スタート位置クリア
For i = x To nx Step sStep
If Cells(ny, i).Value <> "" Then Flg = False
Cells(ny, i).Value = "●"
Next
' 既に通過済みと交差してなければ戻る
If Flg Then Exit Sub
Range("A1:O15") = stArr ' 前の状態をクリア
Flg = True
' 横 → 縦 探索
' 最初に横位置探索(既に通過済と交わればフラグOFF)
If x <= nx Then sStep = 1 Else sStep = -1
Cells(i, y).Value = "" ' スタート位置クリア
For i = x To nx Step sStep
If Cells(y, i).Value <> "" Then Flg = False
Cells(y, i).Value = "●"
Next
' 次に縦位置探索(既に通過済と交わればフラグOFF)
If y <= ny Then sStep = 1 Else sStep = -1
Cells(y, nx).Value = "" ' スタート位置クリア
For i = y To ny Step sStep ' 次に横位置
If Cells(i, nx).Value <> "" Then Flg = False
Cells(i, nx).Value = "●"
Next
End Sub