【概要】

2020/03/26にNintendo Switchで風来のシレン5が発売されることが決定しました。
この報告を受けて嬉しさのあまり、フロアの最短経路を求めるプログラムを書きました。

【環境】

Windows8.1
Excel 2013

【注意点】

本プログラムはフロア全体の把握および、ゴール（階段など次のフロアに移動する場所）が分からなければ最短経路を求めることができません。
風来のシレン5はやったことがないので、フロア全体やゴールが分かるようなアイテムがあるのかは不明です。
そのため本プログラムは使い物にならない可能性がありますが、ゲームが楽しめれば良いのです。

【コード】

Option Explicit

Sub main()
    Dim start As Range
    Dim goal As Range

    ' Sを探す
    Set start = Cells.Find("S")
    ' Gを探す
    Set goal = Cells.Find("G")

    Call breadthFirstSearch(start)
    Call paintShortestPath(goal)
End Sub


' 幅優先探索
Sub breadthFirstSearch(start As Range)
    Dim i As Integer
    Dim j As Integer
    Dim nowRange As Range
    Dim q As mscorlib.Queue
    Set q = CreateObject("System.Collections.Queue")
    Call q.Enqueue(start)
    
    ' 最短距離計算のためスタート地点の値を一時的に数値に変更する
    start.Value = 0
    
    Do While q.Count <> 0
        Set nowRange = q.Dequeue
        ' 現在のセルの周り9セルに対して探索を行う
        For i = -1 To 1
            For j = -1 To 1
                If Cells(nowRange.row + i, nowRange.Column + j).Value = "" _
                    And Cells(nowRange.row + i, nowRange.Column + j).Interior.ColorIndex <> xlNone _
                    And canDiagonalMovement(nowRange, i, j) Then
                        Call q.Enqueue(Cells(nowRange.row + i, nowRange.Column + j))
                        Cells(nowRange.row + i, nowRange.Column + j).Value = nowRange.Value + 1
                End If
            Next
        Next
    Loop
    
    ' 数値に変更されたスタート地点の値を元に戻す
    start.Value = "S"
End Sub

' 斜め移動できるか判定
Function canDiagonalMovement(nowRange As Range, rowIndex As Integer, colIndex As Integer) As Boolean
    If (Cells(nowRange.row, nowRange.Column + colIndex).Interior.ColorIndex <> xlNone _
        And Cells(nowRange.row + rowIndex, nowRange.Column).Interior.ColorIndex <> xlNone) Then
        canDiagonalMovement = True
    Else
        canDiagonalMovement = False
    End If
End Function

' ゴール地点から距離の小さい座標を求め、スタート地点にたどり着くまでの最短経路を
' 黄色塗りつぶしにする
Sub paintShortestPath(goal As Range)
    Dim i As Integer
    Dim j As Integer
    Dim nowRange As Range
    Dim minDistance As Integer: minDistance = 10000
    Dim q As mscorlib.Queue
    Set q = CreateObject("System.Collections.Queue")
    Call q.Enqueue(goal)
    
    ' ゴール地点の周り9セルから距離の最小値を求める
    For i = -1 To 1
        For j = -1 To 1
            If Cells(goal.row + i, goal.Column + j).Value <> "" _
                And Cells(goal.row + i, goal.Column + j).Value < minDistance Then
                    minDistance = Cells(goal.row + i, goal.Column + j).Value
            End If
        Next
    Next
    
    ' 最短距離計算のためゴール地点の値を一時的に数値に変更する
    goal.Value = minDistance + 1

    Do While q.Count <> 0
        Set nowRange = q.Dequeue
        ' 現在のセルの周り9セルに対して探索を行う
        For i = -1 To 1
            For j = -1 To 1
                If Cells(nowRange.row + i, nowRange.Column + j).Value <> "" _
                    And canDiagonalMovement(nowRange, i, j) _
                    And Cells(nowRange.row + i, nowRange.Column + j).Value < nowRange.Value _
                    And Cells(nowRange.row + i, nowRange.Column + j).Interior.Color <> rgbYellow Then
                        Call q.Enqueue(Cells(nowRange.row + i, nowRange.Column + j))
                        Cells(nowRange.row + i, nowRange.Column + j).Interior.Color = rgbYellow
                End If
            Next
        Next
    Loop
    
    ' 数値に変更されたゴール地点の値を元に戻す
    goal.Value = "G"
End Sub

【実行準備】

①黄色以外の好きな色で好きなようにフロアを作ります。
　フロア以外は塗りつぶさないようにして下さい。
　A列と1行目は塗りつぶさないようにして下さい。
②スタート(S)とゴール(G)を決めます。

【実行結果】

スタートから各地点の最短距離が書き込まれます。
スタートからゴールまでの最短経路が黄色で塗りつぶされます。

【参考書籍・サイト】

プログラミングコンテスト攻略のためのアルゴリズムとデータ構造
 VBAで.NET FrameworkのQueueを使う