VBA100本ノック迷宮編：巡回セル問題

公開日：2020-12-31　最終更新日：2021-09-02

VBA100本ノック迷宮編：巡回セル問題

方形セル範囲の左上からスタートし黄色中間地点を通過し右下にゴールする最短経路を探索する問題です。
いわゆる、巡回セールス問題のエクセル版としてセルを使ったものです。
ただし、一度通ったセルは2度通れないという制限がついています。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

出題

#VBA100本ノック迷宮編
方形セル範囲の左上(赤)からスタートし右下(赤)に到達します。
全ての黄色を通過する「最短距離の道順を提示」してください。
・縦横にのみ進む(斜めはダメ)
・同じ道は2度通れない、一筆書きで進む。
経路のうちの1つを回答すれば良い。
※大きさ・黄色数と配置は任意

ひとまずの完成とします。
複数の最短経路を表示してみました。
セル表示はwaitしつつゆっくり表示しています。
経路探索はこのくらいの数なら一瞬で済んでますが、中継点が増えれば当然時間がかかっていきます。
探索を効率化した事による探索抜けがあるのか、そのあたりは検証しきれていません。

中継点を16個にすると結構時間がかかります。
これ以上は、さすがにきついかなと思います。
動画1つ目の経路は袋小路になるパターンでダメ。
次の経路でゴールできています。

少し調整して23秒を16秒くらいにしました。
そこで性能確認として、ランダムに配置して探索時間（秒数）を計測してみました。
ムダと思われる探索を省いて速くしているので配置によってかなり差が出ています。
※配置を残すの忘れた。(泣)
15の階乗=FACT(15)、えーと、、、

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解答VBAコードの解説

先のツイート時点から、さらにVBAは改良しました。
探索漏れがあったのでこれを修正しました。
配置によっては少し遅くなる場合も出てきましたが、全体としては精度を挙げられたと思います。

最初の画像パターンでも通過順の組み合わせは、11!=39,916,800、まともに全組み合わせを確認していたらかなりの時間がかかります。
ましてや黄色が15個になると、15!=1,307,674,368,000、これはもう無理です。
これに対処するには無駄な組み合わせの探索を減らすしかありません。

各区間の距離のマトリックスを作成し、かつ、地点毎の別地点への移動最短距離を出しておきます。
探索の途中で、未探索部分が最短距離で移動したとしても、そこまで探索した最短距離を超える時はそれ以降の探索を打ち切ります。
しかし、地点毎の移動最短距離を全ての地点間にしてしまうと、やはり結構な時間がかかります。

左上から右下への移動だという事を考えると、最も多いのは下または右方向への移動だと考えられます。
そこで、地点毎の移動最短距離の算出時に下または右方向への移動の中の最短距離にしておくことで探索を効率化してみました。
ただし、これではやはり探索漏れが発生する可能性はあるので、本来の移動最短距離での探索も行えるようにしておきました。

最短経路が出れば、後は道順が交錯しないように進めるかを探すことになります。
各拠点から次に進む時の方向として、縦→横、横→縦、どちらを選択するかによってその先で経路が交錯してしまいます。
これも全組み合わせを探すと、2^11とか2^15となってしまい結構な時間がかかります。

この対策として、次の位置と次の次の位置関係によって縦横どちらに進むかを決定するようにしてなるべく早くゴールできるように工夫してみました。
15×15の中に十数個くらいの拠点なら通過出来る道が結構多い事と、移動先は基本的には近隣である為ほとんどの場合はこれでゴールできるようです。

下に掲載したVBAでは、地点の位置関係のパターンは少ないようですが、これも基本は右下に進むということで全位置関係を網羅しなくても進路に問題は無さそうです。
また、同じ最短距離数のルートも複数あるので、それのどれかではゴールできているようです。

それでも漏れている可能性があるので、検証も兼ねて各拠点の縦横出発方向の全組み合わせを試して道順を探すVBAも掲載しました。

また、上のツイート時点とはVBAを変更しているので、改めて時間計測したものを最後に掲載しました。

解答VBAコード

以下のVBAコードは結構長くなりました。


  
    
      Option Explicit


      Const LogLevel = 0 'ログ出力：0=なし,1=時間のみ,2=最短ルート,3=探索ルート

      Const WaitTime = 0　'アニメ間隔ミリ秒：0でアニメなし

      Const SaveHistory = False 'True：最短経路を全て表示

      Const Color開始 = vbRed

      Const Color中間 = vbYellow


      Public ary中間点 As Variant

      Public dic区間距離 As Dictionary

      Public col経路 As Collection

      Public 最短距離 As Long


      '**********************************************************************

      ' メイン処理

      '**********************************************************************


      Sub main()

      　　Call 巡回セル問題(ActiveSheet.Range("A1:O15"))

      End Sub


      Sub 巡回セル問題(ByVal aRng As Range)

      　　Dim st As Double: st = Timer

      　　

      　　If WaitTime = 0 Then Application.ScreenUpdating = False

      　　aRng.ClearContents

      　　If SaveHistory Then

      　　　　With aRng.Worksheet

      　　　　　　.Range(Columns(aRng.Columns.Count + 1), .Columns(.Columns.Count)).Clear

      　　　　End With

      　　End If

      　　

      　　'黄色の中継点を取得:スタートからの距離で並べ替え

      　　ary中間点 = get中間点(aRng)

      　　

      　　Dim i As Long

      　　For i = 1 To 2 '1=浅い探索,2=深い探索

      　　　　Call writeLog(1, "■レベル" & i & "探索開始")

      　　　　

      　　　　'各区間の距離を辞書登録：全区間の全組み合わせ作成

      　　　　Call get区間距離(i)

      　　　　

      　　　　'基準として初期ary中間点の距離を使用

      　　　　最短距離 = get総距離(ary中間点)

      　　　　Set col経路 = New Collection

      　　　　

      　　　　'経路探索：再帰処理

      　　　　Call get経路(ary中間点, LBound(ary中間点) + 1)

      　　　　

      　　　　Call writeLog(1, "レベル" & i & "探索時間：" & Timer - st)

      　　　　

      　　　　'シートへ出力：クロスせずにゴール出来る最短経路を探す

      　　　　If dispRouteOnSheet(aRng, i) Then Exit For

      　　Next

      　　

      　　Call writeLog(1, "レベル" & i & "合計時間：" & Timer - st)

      　　If WaitTime = 0 Then Application.ScreenUpdating = True

      End Sub


      Sub writeLog(ByVal aLevel As Long, ByVal aAry, Optional aDistance = "")

      　　If aLevel > LogLevel Then Exit Sub

      　　If Not IsArray(aAry) Then

      　　　　Debug.Print aAry & aDistance

      　　　　Exit Sub

      　　End If

      　　Dim i As Long, sSplit

      　　For i = LBound(aAry) To UBound(aAry)

      　　　　sSplit = Split(aAry(i), ",")

      　　　　aAry(i) = Cells(CLng(sSplit(0)), CLng(sSplit(1))).Address(False, False)

      　　Next

      　　Debug.Print Join(aAry, "→") & "=" & aDistance

      End Sub


      '**********************************************************************

      ' 最短ルート探索

      '**********************************************************************


      Function get中間点(ByVal aRng As Range) As Variant

      　　Dim ary中間点

      　　Dim i As Long, j As Long

      　　For i = 1 To aRng.Rows.Count

      　　　　For j = 1 To aRng.Columns.Count

      　　　　　　If aRng(i, j).Interior.color = Color開始 Or _

      　　　　　　　 aRng(i, j).Interior.color = Color中間 Then

      　　　　　　　　If IsEmpty(ary中間点) Then

      　　　　　　　　　　ReDim ary中間点(0)

      　　　　　　　　Else

      　　　　　　　　　　ReDim Preserve ary中間点(UBound(ary中間点) + 1)

      　　　　　　　　End If

      　　　　　　　　ary中間点(UBound(ary中間点)) = Format(get距離("1,1", i & "," & j), "00") & ":" & i & "," & j

      　　　　　　End If

      　　　　Next

      　　Next

      　　

      　　Call sortAry1(ary中間点, LBound(ary中間点) + 1, UBound(ary中間点) - 1)

      　　For i = LBound(ary中間点) To UBound(ary中間点)

      　　　　ary中間点(i) = Split(ary中間点(i), ":")(1)

      　　Next

      　　

      　　get中間点 = ary中間点

      End Function


      Sub sortAry1(ByRef argAry As Variant, Optional ByVal aStart As Long = -1, Optional aEnd As Long = -1)

      　　Dim i As Integer, j As Integer, vSwap As Variant

      　　If aStart < 0 Then aStart = LBound(argAry)

      　　If aEnd < 0 Then aEnd = UBound(argAry)

      　　For i = aEnd To aStart Step -1

      　　　　For j = aStart To i - 1

      　　　　　　If argAry(j) > argAry(j + 1) Then

      　　　　　　　　vSwap = argAry(j)

      　　　　　　　　argAry(j) = argAry(j + 1)

      　　　　　　　　argAry(j + 1) = vSwap

      　　　　　　End If

      　　　　Next

      　　Next

      End Sub


Sub get区間距離(ByVal aSearchLevel As Long)

　　Set dic区間距離 = New Dictionary

　　Dim i As Long, j As Long, lngDist As Long, minDist As Long

　　

　　For i = LBound(ary中間点) To UBound(ary中間点) - 1

　　　　minDist = 2 ^ 31 - 1

　　　　For j = LBound(ary中間点) To UBound(ary中間点)

　　　　　　If i <> j Then

　　　　　　　　lngDist = get距離(ary中間点(i), ary中間点(j))

　　　　　　　　dic区間距離(ary中間点(i) & "," & ary中間点(j)) = lngDist

　　　　　　　　If lngDist < minDist Then minDist = lngDist

　　　　　　End If

　　　　Next

　　　　dic区間距離(ary中間点(i)) = minDist

　　Next

　　If aSearchLevel <> 1 Then Exit Sub

　　

　　'レベル1の場合は、下または右への移動を基本として算出

　　Dim sSplit1, sSplit2

　　For i = LBound(ary中間点) To UBound(ary中間点) - 1

　　　　minDist = 2 ^ 31 - 1

　　　　For j = LBound(ary中間点) To UBound(ary中間点)

　　　　　　If i <> j Then

　　　　　　　　sSplit1 = Split(ary中間点(i), ",")

　　　　　　　　sSplit2 = Split(ary中間点(j), ",")

　　　　　　　　If CLng(sSplit2(0)) >= CLng(sSplit1(0)) Or _

　　　　　　　　　 CLng(sSplit2(1)) >= CLng(sSplit1(1)) Then

　　　　　　　　　　lngDist = get距離(ary中間点(i), ary中間点(j))

　　　　　　　　　　If lngDist < minDist Then minDist = lngDist

　　　　　　　　End If

　　　　　　End If

　　　　Next

　　　　dic区間距離(ary中間点(i)) = minDist

　　Next

End Sub


      Sub get経路(ByRef aAry, ByVal i As Long)

      　　Dim j As Long, tDistance As Long, sTmp As String

      　　Dim ary

      　　If i < UBound(aAry) - 1 Then

      　　　　If get総距離(aAry, i) <= 最短距離 Then

      　　　　　　For j = i To UBound(aAry) - 1

      　　　　　　　　ary = aAry

      　　　　　　　　sTmp = aAry(i)

      　　　　　　　　aAry(i) = aAry(j)

      　　　　　　　　aAry(j) = sTmp

      　　　　　　　　Call get経路(aAry, i + 1)

      　　　　　　　　aAry = ary

      　　　　　　Next

      　　　　End If

      　　　　Exit Sub

      　　End If

      　　

      　　tDistance = get総距離(aAry)

      　　If tDistance <= 最短距離 Then

      　　　　Call writeLog(3, aAry, tDistance) 'ログ出力

      　　　　col経路.Add Array(aAry, tDistance)

      　　　　最短距離 = tDistance

      　　End If

      End Sub


      Function get総距離(ByRef aAry, Optional ByVal aLast As Long) As Long

      　　Dim i As Long, j As Long

      　　For i = LBound(aAry) To UBound(aAry) - 1

      　　　　If aLast > 0 And i >= aLast - 1 Then

      　　　　　　get総距離 = get総距離 + dic区間距離(aAry(i))

      　　　　Else

      　　　　　　get総距離 = get総距離 + dic区間距離(aAry(i) & "," & aAry(i + 1))

      　　　　End If

      　　Next

      End Function


      Function get距離(ByVal a中間点1 As String, ByVal a中間点2 As String)

      　　Dim k1, k2

      　　k1 = Split(a中間点1, ",")

      　　k2 = Split(a中間点2, ",")

      　　get距離 = Abs(k1(0) - k2(0)) + Abs(k1(1) - k2(1))

      End Function


      '**********************************************************************

      ' 最短ルート出力

      '**********************************************************************


      Function dispRouteOnSheet(ByVal qRng As Range, aSearchLevel As Long) As Boolean

      　　Dim i As Long, cnt As Long

      　　Dim curRoute As Long, minRoute As Long

      　　

      　　dispRouteOnSheet = False

      　　

      　　Call writeLog(2, "レベル" & aSearchLevel & "最短ルート")

      　　

      　　minRoute = col経路(col経路.Count)(1)

      　　For i = col経路.Count To 1 Step -1

      　　　　If SaveHistory Then

      　　　　　　cnt = cnt + 1

      　　　　　　If cnt > 1 Then

      　　　　　　　　qRng.Offset(, qRng.Columns.Count + 1).Resize(, qRng.Columns.Count + 1).EntireColumn.Insert

      　　　　　　　　qRng.Copy Destination:=qRng.Offset(, qRng.Columns.Count + 1)

      　　　　　　End If

      　　　　End If

      　　　　

      　　　　qRng.ClearContents

      　　　　

      　　　　curRoute = col経路(i)(1)

      　　　　If setRouteOnCells(qRng, col経路(i)(0)) Then

      　　　　　　Call writeLog(2, col経路(i)(0), curRoute)

      　　　　　　dispRouteOnSheet = True

      　　　　Else

      　　　　　　If SaveHistory Then cnt = cnt - 1

      　　　　End If

      　　　　

      　　　　If Not SaveHistory And dispRouteOnSheet Then Exit For

      　　　　

      　　　　If i = 1 Then Exit For

      　　　　curRoute = col経路(i - 1)(1)

      　　　　If (dispRouteOnSheet Or aSearchLevel <= 2) And curRoute > minRoute Then Exit For

      　　Next

      　　

      　　If Not dispRouteOnSheet Then

      　　　　Call writeLog(2, "レベル" & aSearchLevel & "最短ルートなし")

      　　End If

      End Function


      Function setRouteOnCells(ByVal qRng As Range, ByVal aryRoute) As Boolean

      　　setRouteOnCells = False

      　　

      　　Dim i As Long

      　　For i = LBound(aryRoute) + 1 To UBound(aryRoute)

      　　　　'区間のセルに1をセツト

      　　　　If Not writeRouteOnCells(qRng, aryRoute, i, 1) Then

      　　　　　　Exit Function

      　　　　End If

      　　Next

      　　

      　　setRouteOnCells = True

      End Function


      Function writeRouteOnCells(ByVal qRng As Range, ByVal aryRoute, ByVal i As Long, ByVal aNum As Long) As Boolean

      　　Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long

      　　Dim j1 As Long, j2 As Long, j3 As Long, j4 As Long

      　　Dim iStep As Long, jStep As Long, iStep2 As Long, jStep2 As Long

      　　Dim isVertical As Boolean

      　　

      　　writeRouteOnCells = False

      　　

      　　'前回中継点

      　　i1 = Split(aryRoute(i - 1), ",")(0)

      　　j1 = Split(aryRoute(i - 1), ",")(1)

      　　If i = 1 Then qRng.Cells(i1, j1) = 1: waitWriteCell

      　　

      　　'今回中継点

      　　i2 = Split(aryRoute(i), ",")(0)

      　　j2 = Split(aryRoute(i), ",")(1)

      　　

      　　'次の中継点を取得

      　　If i = UBound(aryRoute) Then

      　　　　i3 = i2: j3 = j2

      　　Else

      　　　　i3 = Split(aryRoute(i + 1), ",")(0)

      　　　　j3 = Split(aryRoute(i + 1), ",")(1)

      　　End If

      　　

      　　'次の次の中継点を取得

      　　If i >= UBound(aryRoute) - 1 Then

      　　　　i4 = i3: j4 = j3

      　　Else

      　　　　i4 = Split(aryRoute(i + 2), ",")(0)

      　　　　j4 = Split(aryRoute(i + 2), ",")(1)

      　　End If

      　　

      　　'今回の移動の設定

      　　iStep = Sgn(i2 - i1): jStep = Sgn(j2 - j1)

      　　isVertical = Abs(i2 - i1) > Abs(j2 - j1)

      　　

      　　'次回の移動の設定

      　　iStep2 = Sgn(i3 - i2): jStep2 = Sgn(j3 - j2)

      　　

      　　'次回の移動との関連で縦横優先を切り替える

      　　Select Case True

      　　　　Case iStep > 0 And jStep > 0 And iStep2 < 0 And jStep2 < 0

      　　　　　　isVertical = CBool(j4 > j1)

      　　　　Case iStep > 0 And jStep > 0 And iStep2 = 0 And jStep2 < 0

      　　　　　　isVertical = False

      　　　　Case iStep > 0 And jStep > 0 And iStep2 < 0 And jStep2 = 0

      　　　　　　isVertical = True

      　　　　Case iStep > 0 And jStep > 0 And iStep2 < 0 And jStep2 > 0

      　　　　　　isVertical = True

      　　　　Case iStep > 0 And jStep > 0 And iStep2 > 0 And jStep2 < 0

      　　　　　　isVertical = False

      　　　　　　

      　　　　Case iStep > 0 And jStep < 0 And iStep2 < 0 And jStep2 > 0

      　　　　　　isVertical = False

      　　　　Case iStep > 0 And jStep < 0 And iStep2 < 0 And jStep2 = 0

      　　　　　　isVertical = True

      　　　　Case iStep > 0 And jStep < 0 And iStep2 = 0 And jStep2 > 0

      　　　　　　isVertical = False

      　　　　

      　　　　Case iStep < 0 And jStep > 0 And iStep2 > 0 And jStep2 > 0

      　　　　　　isVertical = True

      　　　　Case iStep < 0 And jStep > 0 And iStep2 > 0 And jStep2 < 0

      　　　　　　isVertical = True

      　　　　Case iStep < 0 And jStep > 0 And iStep2 > 0 And jStep2 = 0

      　　　　　　isVertical = True

      　　　　Case iStep < 0 And jStep > 0 And iStep2 = 0 And jStep2 < 0

      　　　　　　isVertical = False

      　　　　

      　　　　Case iStep < 0 And jStep < 0 And iStep2 > 0 And jStep2 > 0

      　　　　　　isVertical = CBool(i3 > i1)

      　　　　Case iStep < 0 And jStep < 0 And iStep2 = 0 And jStep2 > 0

      　　　　　　isVertical = False

      　　　　Case iStep < 0 And jStep < 0 And iStep2 > 0 And jStep2 = 0

      　　　　　　isVertical = True

      　　End Select

      　　

      　　If isVertical Then

      　　　　Do Until i1 = i2

      　　　　　　i1 = i1 + iStep

      　　　　　　If qRng.Cells(i1, j1).Interior.color = vbYellow Or _

      　　　　　　　 qRng.Cells(i1, j1).Value <> "" Then

      　　　　　　　　Do While qRng.Cells(i1, j1).Value <> "" And j1 <> j2

      　　　　　　　　　　j1 = j1 + jStep

      　　　　　　　　　　If writeCell(qRng, i1 - iStep, j1, aNum) = False Then Exit Function

      　　　　　　　　Loop

      　　　　　　End If

      　　　　　　If writeCell(qRng, i1, j1, aNum) = False Then Exit Function

      　　　　Loop

      　　　　

      　　　　Do Until j1 = j2

      　　　　　　j1 = j1 + jStep

      　　　　　　If qRng.Cells(i1, j1).Interior.color = vbYellow Or _

      　　　　　　　 qRng.Cells(i1, j1).Value <> "" Then

      　　　　　　　　Do While qRng.Cells(i1, j1).Value <> "" And i1 <> i2

      　　　　　　　　　　i1 = i1 + iStep

      　　　　　　　　　　If writeCell(qRng, i1, j1 - jStep, aNum) = False Then Exit Function

      　　　　　　　　Loop

      　　　　　　End If

      　　　　　　If writeCell(qRng, i1, j1, aNum) = False Then Exit Function

      　　　　Loop

      　　Else

      　　　　Do Until j1 = j2

      　　　　　　j1 = j1 + jStep

      　　　　　　If qRng.Cells(i1, j1).Interior.color = vbYellow Or _

      　　　　　　　 qRng.Cells(i1, j1).Value <> "" Then

      　　　　　　　　Do While qRng.Cells(i1, j1).Value <> "" And i1 <> i2

      　　　　　　　　　　i1 = i1 + iStep

      　　　　　　　　　　If writeCell(qRng, i1, j1 - jStep, aNum) = False Then Exit Function

      　　　　　　　　Loop

      　　　　　　End If

      　　　　　　If writeCell(qRng, i1, j1, aNum) = False Then Exit Function

      　　　　Loop

      　　　　

      　　　　Do Until i1 = i2

      　　　　　　i1 = i1 + iStep

      　　　　　　If qRng.Cells(i1, j1).Interior.color = vbYellow Or _

      　　　　　　　 qRng.Cells(i1, j1).Value <> "" Then

      　　　　　　　　Do While qRng.Cells(i1, j1).Value <> "" And j1 <> j2

      　　　　　　　　　　j1 = j1 + jStep

      　　　　　　　　　　If writeCell(qRng, i1 - iStep, j1, aNum) = False Then Exit Function

      　　　　　　　　Loop

      　　　　　　End If

      　　　　　　If writeCell(qRng, i1, j1, aNum) = False Then Exit Function

      　　　　Loop

      　　End If

      　　

      　　qRng.Cells(i2, j2) = i + 1: waitWriteCell

      　　writeRouteOnCells = True

      End Function


      Function writeCell(ByVal qRng As Range, ByVal ii As Long, ByVal jj As Long, _

      　　　　　　　　　 ByVal aNum As Long) As Boolean

      　　If ii < 1 Or ii > qRng.Rows.Count Or _

      　　　 jj < 1 Or jj > qRng.Columns.Count Then Exit Function

      　　If qRng.Cells(ii, jj).Value <> "" Then Exit Function

      　　qRng.Cells(ii, jj).Value = aNum

      　　waitWriteCell

      　　writeCell = True

      End Function


      Sub waitWriteCell()

      　　If WaitTime = 0 Then Exit Sub

      　　Application.Wait [Now()] + WaitTime / (24& * 60& * 60& * 1000&)

      End Sub

移動最短距離の算出時に下または右方向への移動の中の最短距離にした場合に最短距離でゴール出来ない場合がでてきます。
その場合は、本来の移動最短距離での探索に切り替えて再度探索しています。

ゴールで来た場合でも、それが最短経路ではない可能性があります。
探索を省略している中により短い経路が含まれている場合もありえるという事です。
これを考慮するのは全探索することになってしまうので、これはこれで諦めるしかありません。

以下は、各拠点の縦横出発方向の全組み合わせを試行する場合のVBAになります。
さすがに処理時間がかかるので、配列内で試行してゴールできた時にシートに表示しています。
シートへの表示以外の探索部分は、上のVBAコードと同じになります。


  
    
      '**********************************************************************

' 最短ルート出力

'**********************************************************************


Function dispRouteOnSheet(ByVal qRng As Range, aDepth As Long) As Boolean

　　Dim i As Long, cnt As Long

　　Dim curRoute As Long, minRoute As Long


　　dispRouteOnSheet = False


　　Call writeLog(2, "レベル" & aDepth & "最短ルート")


　　minRoute = col経路(col経路.Count)(1)

　　For i = col経路.Count To 1 Step -1

　　　　If SaveHistory Then

　　　　　　cnt = cnt + 1

　　　　　　If cnt > 1 Then

　　　　　　　　qRng.Offset(, qRng.Columns.Count + 1).Resize(, qRng.Columns.Count + 1).EntireColumn.Insert

　　　　　　　　qRng.Copy Destination:=qRng.Offset(, qRng.Columns.Count + 1)

　　　　　　End If

　　　　End If


　　　　curRoute = col経路(i)(1)

　　　　If setRouteOnCells(qRng, col経路(i)(0)) Then

　　　　　　Call writeLog(2, col経路(i)(0), curRoute)

　　　　　　dispRouteOnSheet = True

　　　　Else

　　　　　　If SaveHistory Then cnt = cnt - 1

　　　　End If


　　　　If Not SaveHistory And dispRouteOnSheet Then Exit For


　　　　If i = 1 Then Exit For

　　　　curRoute = col経路(i - 1)(1)

　　　　If (dispRouteOnSheet Or aDepth <= 2) And curRoute > minRoute Then Exit For

　　Next


　　If Not dispRouteOnSheet Then

　　　　Call writeLog(2, "レベル" & aDepth & "最短ルートなし")

　　End If

End Function


Function setRouteOnCells(ByVal qRng As Range, ByVal aryRoute) As Boolean

　　Dim i As Long, ix As Long

　　Dim cnt As Long, tmpBin As String, isVertical As Boolean

　　Dim qAry(), isGoal As Boolean

　　

　　cnt = UBound(aryRoute) - LBound(aryRoute) + 1

　　For ix = 1 To 2 ^ cnt - 1

　　　　ReDim qAry(1 To qRng.Rows.Count, 1 To qRng.Columns.Count)

　　　　Call writeRouteNo(qAry, aryRoute)

　　　　tmpBin = Dec2Bin(ix, cnt)

　　　　

　　　　isGoal = True

　　　　For i = LBound(aryRoute) + 1 To UBound(aryRoute)

　　　　　　isVertical = CBool(Mid(tmpBin, i - LBound(aryRoute) + 1, 1))


　　　　　　'区間のセルに1をセツト

　　　　　　If Not writeRouteOnCells(qAry, aryRoute, i, isVertical, 1) Then

　　　　　　　　isGoal = False

　　　　　　　　Exit For

　　　　　　End If

　　　　Next

　　　　If isGoal Then Exit For

　　Next

　　

　　If isGoal Then qRng.Value = qAry

　　setRouteOnCells = isGoal

End Function


Function writeRouteOnCells(ByRef qAry(), ByVal aryRoute, ByVal i As Long, isVertical As Boolean, aNum As Long) As Boolean

　　Dim i1 As Long, i2 As Long

　　Dim j1 As Long, j2 As Long

　　Dim ii As Long, jj As Long, cnt As Long

　　Dim iStep As Long, jStep As Long


　　writeRouteOnCells = False

　　

　　'前回中継点

　　i1 = Split(aryRoute(i - 1), ",")(0)

　　j1 = Split(aryRoute(i - 1), ",")(1)

　　

　　'今回中継点

　　i2 = Split(aryRoute(i), ",")(0)

　　j2 = Split(aryRoute(i), ",")(1)

　　

　　'今回の移動の設定

　　iStep = Sgn(i2 - i1)

　　jStep = Sgn(j2 - j1)


　　If isVertical Then

　　　　Do Until i1 = i2

　　　　　　i1 = i1 + iStep

　　　　　　If qAry(i1, j1) <> "" Then

　　　　　　　　Do While qAry(i1, j1) <> "" And j1 <> j2

　　　　　　　　　　j1 = j1 + jStep

　　　　　　　　　　If writeCell(qAry, i1 - iStep, j1, i2, j2, aNum) = False Then Exit Function

　　　　　　　　Loop

　　　　　　End If

　　　　　　If writeCell(qAry, i1, j1, i2, j2, aNum) = False Then Exit Function

　　　　Loop

　　　　

　　　　Do Until j1 = j2

　　　　　　j1 = j1 + jStep

　　　　　　If qAry(i1, j1) <> "" Then

　　　　　　　　Do While qAry(i1, j1) <> "" And i1 <> i2

　　　　　　　　　　i1 = i1 + iStep

　　　　　　　　　　If writeCell(qAry, i1, j1 - jStep, i2, j2, aNum) = False Then Exit Function

　　　　　　　　Loop

　　　　　　End If

　　　　　　If writeCell(qAry, i1, j1, i2, j2, aNum) = False Then Exit Function

　　　　Loop

　　Else

　　　　Do Until j1 = j2

　　　　　　j1 = j1 + jStep

　　　　　　If qAry(i1, j1) <> "" Then

　　　　　　　　Do While qAry(i1, j1) <> "" And i1 <> i2

　　　　　　　　　　i1 = i1 + iStep

　　　　　　　　　　If writeCell(qAry, i1, j1 - jStep, i2, j2, aNum) = False Then Exit Function

　　　　　　　　Loop

　　　　　　End If

　　　　　　If writeCell(qAry, i1, j1, i2, j2, aNum) = False Then Exit Function

　　　　Loop

　　　　

　　　　Do Until i1 = i2

　　　　　　i1 = i1 + iStep

　　　　　　If qAry(i1, j1) <> "" Then

　　　　　　　　Do While qAry(i1, j1) <> "" And j1 <> j2

　　　　　　　　　　j1 = j1 + jStep

　　　　　　　　　　If writeCell(qAry, i1 - iStep, j1, i2, j2, aNum) = False Then Exit Function

　　　　　　　　Loop

　　　　　　End If

　　　　　　If writeCell(qAry, i1, j1, i2, j2, aNum) = False Then Exit Function

　　　　Loop

　　End If

　　

　　writeRouteOnCells = True

End Function


Function Dec2Bin(ByVal aNum As Long, aCnt As Long) As String

　　Dim rtn As String

　　Dim tNum As Long

　　Do

　　　　tNum = aNum \ 2

　　　　If tNum = 0 Then

　　　　　　rtn = (aNum Mod 2) & rtn

　　　　　　Exit Do

　　　　End If

　　　　rtn = (aNum Mod 2) & rtn

　　　　aNum = tNum

　　Loop

　　Dec2Bin = Right(String(aCnt, "0") & rtn, aCnt)

End Function


Sub writeRouteNo(ByRef qAry(), ByVal aryRoute)

　　Dim i As Long, i2 As Long, j2 As Long

　　For i = LBound(aryRoute) To UBound(aryRoute)

　　　　i2 = Split(aryRoute(i), ",")(0)

　　　　j2 = Split(aryRoute(i), ",")(1)

　　　　qAry(i2, j2) = i - LBound(aryRoute) + 1

　　Next

End Sub


Function writeCell(ByRef qAry(), _

　　　　　　　　　 ByVal i1 As Long, ByVal j1 As Long, _

　　　　　　　　　 ByVal i2 As Long, ByVal j2 As Long, _

　　　　　　　　　 ByVal aNum As Long) As Boolean

　　If i1 < 1 Or i1 > UBound(qAry, 1) Or _

　　　 j1 < 1 Or j1 > UBound(qAry, 2) Then

　　　　Exit Function

　　End If

　　If qAry(i1, j1) <> "" And (i1 <> i2 Or j1 <> j2) Then

　　　　Exit Function

　　End If

　　qAry(i1, j1) = aNum

　　writeCell = True

End Function

中間地点数10個～15個での処理時間比較

テストに使用したVBAになります。


  
    
      '**********************************************************************

' ランダム配置テスト

'**********************************************************************


Sub ランダムテスト()

　　Const cnsTestTimes = 100

　　Dim ws As Worksheet

　　Set ws = Worksheets("ランダムテスト結果")

　　Worksheets("ランダムテスト").Select

　　

　　Dim i As Long, cnsRelayPoint As Long, st As Double

　　For cnsRelayPoint = 10 To 15

　　　　For i = 1 To cnsTestTimes

　　　　　　Application.StatusBar = cnsRelayPoint & "点：" & i & "/" & cnsTestTimes

　　　　　　Call ランダム配置(cnsRelayPoint)

　　　　　　DoEvents

　　　　　　Application.Wait [Now()] + 100 / (24& * 60& * 60& * 1000&)

　　　　　　DoEvents

　　　　　　st = Timer

　　　　　　Call main

　　　　　　ws.Cells(i + 1, cnsRelayPoint - 8) = Timer - st

　　　　　　DoEvents

　　　　　　Application.Wait [Now()] + 1000 / (24& * 60& * 60& * 1000&)

　　　　　　DoEvents

　　　　Next

　　Next

End Sub


Sub ランダム配置(ByVal aNum As Long)

　　Dim rng As Range: Set rng = Range("A1:O15")

　　rng.Clear

　　rng.Item(1).Interior.color = Color開始

　　rng.Item(rng.Count).Interior.color = Color開始

　　

　　Dim i As Long, myNum As Long

　　Dim myFlag(1 To 225) As Boolean

　　

　　Randomize

　　For i = 1 To aNum

　　　　Do

　　　　　　myNum = Int((224 - 2 + 1) * Rnd + 2)

　　　　Loop Until myFlag(myNum) = False

　　　　

　　　　rng.Item(myNum).Interior.color = vbYellow

　　　　myFlag(myNum) = True

　　Next i

End Sub

各中間地点数ごとに100回の実行結果になります。

中間地点数	10	11	12	13	14	15
最小値	0.016	0.047	0.109	0.078	0.266	2.093
中央値	0.094	0.422	2.207	3.176	8.718	28.026
平均値	0.181	0.777	3.402	7.188	16.404	52.295
最大値	3.500	10.922	26.445	131.891	231.656	398.727

16個以上になっても数秒で終わる配置もありますが、配置によっては10分以上かかってしまうので、今回の方法では15個くらいが限界だと考えた方が良さそうです。
特に等距離に多くの地点が密集しているような配置の場合、結果的に多くの組み合わせを探索することになり時間がかかります。

これは、いろいろテストしている過程でたまたま見つけた配置ですが、900秒程かかります。
実行ログでは最短距離になる経路が44パターン表示されています。
（ただし実際に道順が交差せずにゴール出来たのは9パターンです。）
つまり、ほとんどの組み合わせを試行したことになるのでしょう。
最後まで探索しなければ、どれが最短か分からないので、こういう事になってしまいます。
この配置なら、人間が目で順に辿っていけば最短距離を探せるような気がします。
この辺りのアルゴリズムを工夫出来ればより速く最短距離を探せるようになるのですが、それが難しいですね。

もっと地点数が多くなるなら、左上から右下に向かって近隣を探しながら進む方法が良いのではないかと思います。
ただし、それが最短距離かどうかは分からないです。
仮に20地点を超えてしまうような場合は、それが最短かどうかを検証する事さえ難しくなってきます。

同じテーマ「VBA100本ノック」の記事

95本目：図形のテキストを検索するフォーム作成
 96本目：Accessデータを取得（マスタ結合&抽出）
97本目：Accessデータを取得（グループ集計）
98本目：席替えルールが守られているか確認
 99本目：自動席替え（行列と前後左右が全て違うように）
100本目：WEBから100本ノックのリストを取得
 魔球編：組み合わせ問題
 魔球編：閉領域の塗り潰し
迷宮編：巡回セル問題
魔球編：2桁の最小公倍数
 参加者様ご紹介

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.マクロとは？VBAとは？VBAでできること｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
迷宮編：巡回セル問題

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA練習問題
VBA100本ノック迷宮編：巡回セル問題