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

VBAを100本の練習問題で鍛えます
公開日:2020-12-31 最終更新日:2021-09-02

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


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


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


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック 迷宮編

マクロ VBA 100本ノック 迷宮編


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

マクロ VBA 100本ノック 迷宮編


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

マクロ VBA 100本ノック 迷宮編


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

マクロ VBA 100本ノック 迷宮編


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個くらいが限界だと考えた方が良さそうです。
特に等距離に多くの地点が密集しているような配置の場合、結果的に多くの組み合わせを探索することになり時間がかかります。

マクロ VBA 100本ノック 迷宮編

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

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




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

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


新着記事NEW ・・・新着記事一覧を見る

VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
累計を求める数式あれこれ|エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE|エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。|エクセル雑感(2023-12-28)
VBAでクリップボードへ文字列を送信・取得する3つの方法|VBA技術解説(2023-12-07)
難しい数式とは何か?|エクセル雑感(2023-12-07)
スピらない スピル数式 スピらせる|エクセル雑感(2023-12-06)


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

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




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


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



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