Excel VBAで迷路の最短経路を調べよう！
記事IT・テクノロジー
はじめに
Excel VBAは、主にビジネスの現場で利用されるプログラミング環境ですが、その柔軟性により、幅広い用途に使用することが可能です。
Excel VBAを使うと何千何万回という計算を瞬時に行うことができます。
今回のブログ記事ではプログラムを使うとどんな計算が一瞬でできるのか？ということを簡単にお伝えしたいと思います。
迷路探索をする
以上のような迷路を用意してみました。
黒く塗られている箇所は移動できません。そのような制約のなかで、上下左右に移動を繰りかえして、SからGのマスまで最短何手でいけるでしょうか？
愚直に全ての経路を試す、ということが思いつきますが、それぞれのマスでの選択肢が、来た道を除いて最大で３つあります。その×３の選択肢を繰り返すので、膨大な場合の数になることが想定されます。
アルゴリズムを使うと簡単に考えられる
これは競技プログラマーの間では「幅優先探索」を用いて解けるということで、有名な問題です。
以下のようなアルゴリズム（手続き）を使って解くことができます。
それは、スタート地点から行けるマスに1を書きこみ、そこから行ける場所に２を書きこみ…というように近い所から数字を埋めていくことです。
このように表を更新していくことで、最短経路を調べることができます。
とはいえ、表を一つ一つ埋めるのも大変です。
そこでVBAのようなプログラムを使うとこの作業を一瞬で終わらせることが可能です。
マクロを走らせると16回でたどり着けることが分かりました。
プログラム化の素晴らしいことは、一度作成してしまえば同じような作業を行わなくてもよくなるところです。
今回はたかだか9x9の迷路でした。しかし、もっと巨大な迷路に遭遇しても作業は一瞬で終わります。
例えばこのように３倍に拡張した迷路でも…。
一瞬で38回の移動でたどり着けることが分かりました。
ソースコード
今回のソースコードを記載します。
まずは、効率的に探索を行えるようDequeという両端キューデータ構造をクラスモジュールで作成しました。
```vba
' Deque クラスモジュール
Private pItems As Collection
Private Sub Class_Initialize()
Set pItems = New Collection
End Sub
' 要素を右端に追加
Public Sub PushRight(value As Variant)
pItems.Add value
End Sub
' 右端から要素を削除して返す
Public Function PopRight() As Variant
Dim index As Long
index = pItems.Count
If index > 0 Then
PopRight = pItems(index)
pItems.Remove index
Else
PopRight = Empty ' または適切なエラーハンドリング
End If
End Sub
' 要素を左端に追加
Public Sub PushLeft(value As Variant)
pItems.Add value, Before:=1
End Sub
' 左端から要素を削除して返す
Public Function PopLeft() As Variant
If pItems.Count > 0 Then
PopLeft = pItems(1)
pItems.Remove 1
Else
PopLeft = Empty
End If
End Function
' 要素数を返す
Public Function Count() As Long
Count = pItems.Count
End Function
```
このDequeクラスを使い、迷路を探索するプログラムが以下になります
```vba
Sub bfs()
Dim ws As Worksheet
Set ws = ActiveSheet
' 高さの範囲
Dim fromH As Long
Dim toH As Long
fromH = 2
toH = 28
' 横の範囲
Dim fromW As Long
Dim toW As Long
fromW = 2
toW = 28
' スタートポジション
Dim r As Long
Dim c As Long
' ゴールのマス
Dim goalR As Long
Dim goalC As Long
' スタート、ゴール地点を探す
Dim i As Long
Dim j As Long
For i = fromH To toH
For j = fromW To toW
If ws.Cells(i, j).value = "S" Then
r = i
c = j
End If
If ws.Cells(i, j).value = "G" Then
goalR = i
goalC = j
End If
Next j
Next
' 両端キュークラスをインスタンス化
Dim myDeque As Deque
Set myDeque = New Deque
' 行番,列番,回数をカンマ区切りで加える
Dim elm As String
elm = r & "," & c & "," & 0
myDeque.PushRight elm
' キューがなくなるまで繰り返す
Do While myDeque.Count > 0
' キューから要素を取り出す
elm = myDeque.PopLeft()
' 現在の位置と移動回数を取得
Dim parts() As String
parts = Split(elm, ",")
r = CLng(parts(0))
c = CLng(parts(1))
Dim steps As Long
steps = CLng(parts(2))
' ゴールに達したので抜ける
If r = goalR And c = goalC Then
MsgBox "ゴールに" & steps & "回の移動で到達しました"
Exit Do
End If
' 上下左右に移動する
Dim newR As Long
Dim newC As Long
Dim flg1 As Boolean
Dim flg2 As Boolean
For i = -1 To 1
For j = -1 To 1
newR = r + i
newC = c + j
flg1 = False
flg2 = False
' 左右の移動に該当
If i = 0 And j <> 0 Then
flg1 = True
End If
If i <> 0 And j = 0 Then
flg2 = True
End If
If flg1 Or flg2 Then
' 範囲内かチェック
If newR >= fromH And newR <= toH And newC >= fromW And newC <= toW Then
' 新しい場所が壁ではない且つ未訪問かチェック
If ws.Cells(newR, newC).value = "" Or ws.Cells(newR, newC).value = "G" Then
' queに加える
ws.Cells(newR, newC).value = steps + 1
elm = newR & "," & newC & "," & steps + 1
myDeque.PushRight elm
End If
End If
End If
Next j
Next i
Loop
End Sub
```
終わりに
このようにプログラムを用いると、難しそうな処理も一瞬で終わらせることができます。
今回は迷路探索プログラムを紹介しました。ですが、元々は業務で使用するマクロを日常的に書いています。最後に宣伝となります。そんな私のVBAプログラム、効率化ファイルを最低3,000円という価格で納品します。ぜひご気軽に相談をしてください。
