[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『最短経路探索をしたいです。』（まる）
最短経路探索をしたいです。
各アドレス(分岐点や行き止り点)に番号が付与されており、
アドレス間には距離が設定されています。
アドレスのStart-Goalを読み込むことで、
アドレス間の距離の合計を求めることを目標としています。
シート1にはアドレス間距離が記載されています。
A,B列は各アドレス番号、C列はアドレス間距離です。
A列 B列 C列 1 1 3 100 2 2 3 100 3 3 4 134 4 4 20 20 5 4 32 40 6 5 32 46 7 5 10 80 8 5 330 150 9 21 32 321 … … … …
シート2には求めたいアドレスのStart-Goalが記載されています。
A,B列はアドレスのStart-Goal、C列は空欄です。
A列 B列 C列 1 1 20 2 20 10 3 10 330 4 2 21 5 21 2 6 20 21 7 1 20 … … … …
最終的にはシート2のC列に、シート1のアドレス間距離の和を出力したいです。カッコ内は参考です。
1、7列目や4、5列目のようにすでに計算されているStart-Goalもでてきます。
A列 B列 C列 1 1 20 254 (1→3→4→20、100+134+20) 2 20 10 186 (20→4→32→5→10、20+40+46+80) 3 10 330 230 (10→5→330、80+150) 4 2 21 591 (2→3→4→32→21、100+134+40+321) 5 21 2 591 (2→3→4→32→21、100+134+40+321) 6 20 21 381 (20→4→32→21、20+40+321) 7 1 20 254 (1→3→4→20、100+134+20) … … … …
今回は簡単な迷路ですが、実際は50回程度の足し算が必要になるほどの迷路の大きさになっており、Start-Goalの個数も100個を超えるため、
ある程度の速度がほしいです。
探索プログラムを組んだことがないのでご協力お願いします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
Dim dic As Object, c As Range, cc As Range, m As Long, n As Long, tot As Long, comm As String, totcomm As String
Set dic = CreateObject("Scripting.dictionary")
For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
dic(c.Value & "→" & c.Offset(, 1).Value) = c.Offset(, 2).Value
dic(c.Offset(, 1).Value & "→" & c.Value) = c.Offset(, 2).Value
Next c
Sheets("Sheet2").Range("C:D").ClearContents
For Each cc In Sheets("Sheet2").Range("A:A").SpecialCells(2)
Sheets("Sheet3").Cells.ClearContents
For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
If c.Value = cc.Value Then Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(c.Value, c.Offset(, 1).Value)
If c.Offset(, 1).Value = cc.Value Then Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(c.Offset(, 1).Value, c.Value)
Next c
m = 2
Do
n = Sheets("Sheet3").Cells(m, Columns.Count).End(xlToLeft).Value
If WorksheetFunction.CountA(Sheets("Sheet3").Rows(m)) = 0 Then cc.Offset(, 2).Value = "該当なし": Exit Do
For Each c In Sheets("Sheet1").Range("A:A").SpecialCells(2)
Set r = Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
If c.Value = n Then
If WorksheetFunction.CountIf(Sheets("Sheet3").Rows(m), c.Offset(, 1).Value) = 0 Then
Sheets("Sheet3").Rows(m).EntireRow.Copy r
Sheets("Sheet3").Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value = c.Offset(, 1).Value
End If
End If
If c.Offset(, 1).Value = n Then
If WorksheetFunction.CountIf(Sheets("Sheet3").Rows(m), c.Value) = 0 Then
Sheets("Sheet3").Rows(m).EntireRow.Copy r
Sheets("Sheet3").Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value = c.Value
End If
End If
Next c
Set r = Sheets("Sheet3").Cells.Find(cc.Offset(, 1).Value, , , xlWhole)
If Not r Is Nothing Then
comm = Join(Application.Transpose(Application.Transpose(r.EntireRow.Cells.SpecialCells(2))), "→")
tot = 0
totcomm = ""
For i = 0 To UBound(Split(comm, "→")) - 1
tot = tot + dic(Split(comm, "→")(i) & "→" & Split(comm, "→")(i + 1))
totcomm = totcomm & "+" & dic(Split(comm, "→")(i) & "→" & Split(comm, "→")(i + 1))
Next i
cc.Offset(, 2).Value = tot
cc.Offset(, 3).Value = comm & "、" & totcomm
Exit Do
End If
DoEvents
m = m + 1
Loop
Next cc
End Sub
（mm） 2022/01/19(水) 15:20
その大きい場合の実例を出してもらうと取り組みやすいですね。
（γ） 2022/01/20(木) 07:50
4 2 21 591 (2→3→4→32→21、100+134+40+321) 5 21 2 591 (2→3→4→32→21、100+134+40+321) は、下記のようにならないんですか？ 4 2 21 595 (2→3→4→32→21、 100+134+40+321) 5 21 2 595 (21→32→4→3→2、 321+40+134+100)
（γ） 2022/01/20(木) 08:11
知的好奇心をくすぐられたので、書いてみました。 前提は各データに抜け無しです。
Sub sample()
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Worksheets(1)
Dim routeDic As Object
Dim costDic As Object
Set routeDic = CreateObject("Scripting.Dictionary")
Set costDic = CreateObject("Scripting.Dictionary")
Dim temp As Variant
temp = ws1.Range("A1", ws1.Cells(ws1.Rows.Count, "C").End(xlUp)).Value
Dim i As Long
Dim val(2) As Long
For i = LBound(temp, 1) To UBound(temp, 1)
val(0) = temp(i, 1)
val(1) = temp(i, 2)
val(2) = temp(i, 3)
If Not routeDic.Exists(val(0)) Then
routeDic.Add val(0), CreateObject("Scripting.Dictionary")
End If
routeDic(val(0)).Add val(1), i
If Not routeDic.Exists(val(1)) Then
routeDic.Add val(1), CreateObject("Scripting.Dictionary")
End If
routeDic(val(1)).Add val(0), i
costDic.Add i, val(2)
Next
Erase temp
Set ws1 = Nothing
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets(2)
With ws2
temp = .Range("A1").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row, 4).Value
End With
Dim isGool As Boolean
Dim cost As Long
Dim passed() As Variant
Dim route() As String
Dim v As Variant
For i = LBound(temp, 1) To UBound(temp, 1)
cost = 0
passed = Array()
route = Split("")
isGool = False
MatchRoute routeDic, passed, route, temp(i, 1), temp(i, 2), isGool
If isGool Then
For Each v In passed
cost = cost + costDic(v)
Next
temp(i, 3) = cost
temp(i, 4) = Join(route, "⇒")
Else
temp(i, 3) = CVErr(xlErrNA)
End If
Next
ws2.Range("A1").Resize(UBound(temp, 1), UBound(temp, 2)).Value = temp
End Sub
Private Sub MatchRoute(srcRouteDic As Object, srcPassed() As Variant, srcRoute() As String, ByVal pos As Long, ByVal gool As Long, isGool As Boolean)
Dim passed() As Variant
Dim route() As String
Dim v As Variant
Dim doThrough As Boolean
For Each v In srcRouteDic(pos).Keys
If isGool Then Exit For
doThrough = False
If UBound(srcPassed) >= 0 Then
With Application
If .IfError(.Match(srcRouteDic(pos)(v), srcPassed, 0), 0) > 0 Then doThrough = True
End With
End If
If doThrough = False Then
passed = srcPassed
ReDim Preserve passed(UBound(passed) + 1)
passed(UBound(passed)) = srcRouteDic(pos)(v)
route = srcRoute
ReDim Preserve route(UBound(route) + 1)
route(UBound(route)) = pos
If v = gool Then
ReDim Preserve route(UBound(route) + 1)
route(UBound(route)) = v
isGool = True
Exit For
End If
MatchRoute srcRouteDic, passed, route, v, gool, isGool
End If
Next
If isGool Then
srcPassed = passed
srcRoute = route
End If
End Sub
（tkit） 2022/01/20(木) 12:10
Private PointList As Object
Private TimeOut As Long
Private result() As Variant
'実行メソッド
Public Sub Button_Click()
Dim point_array As Variant: point_array = Sheet1.Range("A1:C9").Value
Dim rout_array As Variant: rout_array = Sheet2.Range("A1:B7").Value
Set PointList = GetPointList(point_array)
Dim i As Long, rout As Object
For i = 1 To UBound(rout_array)
TimeOut = 0
Erase result
Set rout = CreateObject("Scripting.Dictionary")
rout.Add CStr(rout_array(i, 1)), CStr(rout_array(i, 1))
Call subrout(rout_array(i, 1), "", rout_array(i, 2), 0, rout, TimeOut)
Debug.Print i & vbTab & Join(result, vbTab)
Next i
End Sub
'DictionaryObjectのディープコピー用関数
Private Function DicDeepCopy(ByVal dic As Object) As Object
Dim rtn As Object: Set rtn = CreateObject("Scripting.Dictionary")
Dim key As Variant
For Each key In dic.Keys
rtn.Add key, dic(key)
Next key
Set DicDeepCopy = rtn
End Function
'再起処理用メインルーチン
Private Function subrout(ByVal st As String, ByVal er As String, ByVal ed As String, ByVal bt As Long, ByVal rout As Object, ByVal tu As Long)
Dim rsl As Collection: Set rsl = GetStRecords(st, er)
If rsl.Count = 0 Then Exit Function
Dim buf As Variant, t As Long, var As Variant, dic As Object
For Each buf In rsl
If buf(0) = st Then
var = Array(buf(1), buf(0))
Else
var = Array(buf(0), buf(1))
End If
If buf(0) = ed Or buf(1) = ed Then
If TimeOut = 0 Or TimeOut > bt + buf(2) Then
TimeOut = bt + buf(2)
result = Array(Join(rout.Items, "->") & "->" & var(0), bt + buf(2))
End If
Else
If (TimeOut = 0 Or TimeOut > bt + buf(2)) And Not rout.Exists(var(0)) Then
Set dic = DicDeepCopy(rout)
dic.Add CStr(var(0)), CStr(var(0))
Call subrout(var(0), var(1), ed, bt + buf(2), dic, TimeOut)
End If
End If
Next buf
End Function
'通過ポイントのリスト作成
Private Function GetPointList(ByVal ary As Variant) As Object
Dim rs As Object: Set rs = CreateObject("ADODB.Recordset")
With rs
With .Fields
.Append "POINT1", 200, 255
.Append "POINT2", 200, 255
.Append "TIME", 14
End With
.Open
End With
Dim i As Long
For i = 1 To UBound(ary, 1)
rs.AddNew Array("POINT1", "POINT2", "TIME"), Array(ary(i, 1), ary(i, 2), ary(i, 3))
Next i
rs.Update
Set GetPointList = rs
End Function
'フィルタかけてリスト内から検索
Private Function GetStRecords(ByVal st As String, ByVal er As String) As Collection
With PointList
.Filter = "(POINT1='" & st & "' AND POINT2<>'" & er & "') OR (POINT1<>'" & er & "' AND POINT2='" & st & "')"
Dim rtn As New Collection
If .RecordCount > 0 Then
.MoveFirst
Do Until .EOF
rtn.Add Array(.Fields("POINT1").Value, .Fields("POINT2").Value, .Fields("TIME").Value)
.MoveNext
Loop
End If
End With
Set GetStRecords = rtn
End Function
（モゲラ） 2022/01/20(木) 13:27
せっかく書いたものが無駄にならないよう、このあたりで、 標準的なダイクストラ法を使ったものを載せておきましょう。
Option Explicit Rem 最短路検索
Dim N As Long 'nodeの数 Const INF As Long = 99999 '最大値 Dim mat() As Long '隣接行列 Dim v() As Long '確定フラグ Dim distance() As Long '始点からnodeまでの距離 Dim pointer() As Long '前のnodeへのポインタ Dim dic As Object Dim dicR As Object Dim ws As Worksheet Dim wsOut As Worksheet
Sub main()
Dim start&
Dim i&, j&, k&
Dim min&, p&
Dim st$, ed$
Set ws = Worksheets("Sheet1")
Set wsOut = Worksheets("Sheet2")
Set dic = CreateObject("Scripting.Dictionary")
Set dicR = CreateObject("Scripting.Dictionary")
Call setting ' 重み付き隣接行列のセット
For i = 1 To wsOut.[A1].CurrentRegion.Rows.Count
st = CStr(wsOut.Cells(i, "A").Value)
ed = CStr(wsOut.Cells(i, "B").Value)
start = dic(st)
For k = 1 To N
distance(k) = INF
v(k) = 0
Next k
distance(start) = 0
pointer(start) = 0
For j = 1 To N
'最小のnodeを探す
min = INF
For k = 1 To N
If v(k) = 0 And distance(k) < min Then
p = k
min = distance(k)
End If
Next k
v(p) = 1 '最小のnodeを確定する
If min = INF Then
MsgBox "適切なグラフでない"
Exit Sub
End If
For k = 1 To N
'ｐを経由してｋに至る長さがそれまでの最短路より小さい時は更新する
If distance(p) + mat(p, k) < distance(k) Then
distance(k) = distance(p) + mat(p, k)
pointer(k) = p
End If
Next k
Next j
wsOut.Cells(i, "C").Value = formatting(st, ed) '出力のための形式整備
Next
End Sub
Function setting()
Dim s$
Dim p&
Dim e
Dim j&, k&
Dim st$, ed$
' node番号と 整数インデックスとの相互変換をdictionaryに保持
For Each e In ws.[A1].CurrentRegion.Resize(, 2)
s = e.Value
If Not dic.Exists(s) Then
p = p + 1
dic(s) = p
dicR(p) = s
End If
Next
N = dic.Count 'nodeの数
ReDim mat(1 To N, 1 To N) '隣接行列
ReDim v(1 To N) '確定フラグ
ReDim distance(1 To N) 'nodeまでの距離
ReDim pointer(1 To N) '前のnodeへのポインタ
'いったん大きい数をセット
For j = 1 To N
For k = 1 To N
mat(j, k) = INF
Next
Next
'距離データを隣接行列に読み込む
For Each e In ws.[A1].CurrentRegion.Resize(, 1)
st = CStr(e.Value)
ed = CStr(e.Offset(, 1).Value)
mat(dic(st), dic(ed)) = e.Offset(, 2).Value
mat(dic(ed), dic(st)) = e.Offset(, 2).Value '無向グラフのため逆方向もセット
Next
End Function
Function formatting(st As String, ed As String) As String
Dim j As Long
Dim p As Long
Dim ary(), ary2(), ary3()
Dim s1$, s2$, s3$
Dim c As Long
j = dic(ed)
' ------------ s1(距離合計）の作成
s1 = distance(j)
' ------------ s2("1→3→4→20”部分)の作成
c = 0
ReDim Preserve ary(0 To c)
ary(c) = j
'pointerは終点から始点に向かうものなので、逆転させる必要
p = j
Do While pointer(p) <> 0
c = c + 1
ReDim Preserve ary(0 To c)
ary(c) = pointer(p)
p = pointer(p)
Loop
'----------------逆転したうえで、文字列化
ReDim ary2(0 To UBound(ary))
For j = 0 To UBound(ary)
ary2(j) = dicR(ary(UBound(ary) - j))
Next
s2 = Join(ary2, "→")
'----------------- s3("100+134+20") の作成
ReDim ary3(0 To UBound(ary) - 1)
For j = 0 To UBound(ary) - 1
ary3(j) = mat(ary(UBound(ary) - j - 1), ary(UBound(ary) - j))
Next
s3 = Join(ary3, "+")
formatting = s1 & " (" & s2 & "、 " & s3 & ")"
End Function
# 河西氏の著作を参考にさせていただきました。
（γ） 2022/01/20(木) 14:42
私が提示したコードは、最小距離を求めていなく、コード上最初に 到達したものを出しているだけです。 実用するのであれば、他の方のコードを参照してください。
改修も出来ますが、必要は無いかな、と。
＞標準的なダイクストラ法を使ったものを載せておきましょう。 アルゴリズムを知る知らないで、設計時間や結果の信頼性に大きな差が 出てしまいますね。 γさん、勉強になりました。
（tkit） 2022/01/20(木) 16:00
mmさん
先に上げた事例をmmさんのコードで実施後、
自身の巨大迷路で確認してみましたが、4時間経ってもゴールできていませんでした。
17000回くらい計算していました。
小さめの迷路であれば1つあたり十数秒でゴールできることは確認できています。
ありがとうございます。
γさん (以前も問題解決にご協力いただいており、感謝しております)
・巨大迷路の事例提示は準備します。少々時間がかかるかもしれません…。
・スタートとゴールが逆転しているので本来は計算も逆になりますが、
最終的にほしいのは合計値なので、無駄な計算を省けるのであれば省きたいなという思いがありました。
すでに計算している、道のりや逆転している道のりは、計算結果を参照すれば良いかなと。
tkitさん、モゲラさん
コードの提供ありがとうございます。
しらみつぶしに行けば、ゴールまでたどり着けるかなと思ってみたはいいものの、
コードにすることの難しさがありました。
（まる） 2022/01/20(木) 18:57
後学のために、それぞれ提示してあるコードで、
処理時間を教えてください。
サンプル迷路１つで構いません。
（tkit） 2022/01/21(金) 08:11
tkitさん、コメントありがとうございました。
以下、質問者さんへ。
今更ですが、そもそもこの話は、どんなことが背景になっているんでしょうか。 そのあたりを少し説明されたほうが回答者も実感が湧いて取り組めます。
例えば、 ・各節点は営業所で、 ・距離は営業所間の距離を示していて、 配送センターが各営業所を巡回して配送していく際の、 もしくは、余裕のある営業所が別の営業所に融通する際の、 最短距離を概略掴みたいのです、とかなんとか言った話が欲しいですね。
なお、提示された例は余り適切な例ではなかったですね。今更ですが。
A列 B列 C列
1 3 100
2 3 100
3 4 134
4 20 20
4 32 40
5 32 46
5 10 80
5 330 150
21 32 321
これだと
2 20 21 10
| | | |
1 -- 3 -- 4 -- 32 -- 5 -- 330
というグラフと同型になり、
どの2つのnodeも、単一のパスでしかつながっていませんので、
最短も何もないじゃないですか。
最短路ということを考える余地のないケースです。
まあ、現実には、そうした前提に近い状況なのかもしれませんが。
（そうした前提のもとで提案されたコードを現実のものに適用すると、 場合によっては、閉路を何度も巡ってしまうこともあり得ます。)
例えば、以下のような例であれば、 A列 B列 C列 1 2 4 1 3 3 2 3 1 2 4 1 2 5 5 4 5 3 3 6 2 5 6 1 5 7 2 6 7 4 最短路という話が出てくる簡単な例になっているでしょう。 いかがでしたでしょうか。
（γ） 2022/01/21(金) 21:16
こんにちは。
| γさん (以前も問題解決にご協力いただいており、感謝しております) | ・巨大迷路の事例提示は準備します。少々時間がかかるかもしれません…。 ということですが、特段の作成作業をしていただく必要はありません。
| 先に上げた事例をmmさんのコードで実施後、 | 自身の巨大迷路で確認してみましたが、4時間経ってもゴールできていませんでした。 ということでしたので、現状のもので結構です。 もちろん、何か固有名詞があって支障があるのであれば、 適当に置換したり、数字にでも変換してもらえばと思います。 基本的には、その4時間経ってもゴールしなかった例をそのまま提示ください。
なお、ご指摘があったように提示されたものの評価をしてもらえばありがたい。 （γ） 2022/01/25(火) 17:21
・背景について
こちらはある製品の電気回路を数字で示しています。
各終点はスイッチやランプなどの負荷に該当し、各節点は電気回路の分岐にあたります。
算出したい距離は各回路の長さに相当します。
シート2において、同一のStart-Goalが複数回出てくるのはそのためです。
数字で示された回路図が.txt形式で得られますが、
目で追うのも大変であるためどうにかしたいと考えていました。
通常の図面もありますが、計算回数が膨大であることと、その分ミスもあるため自動化したいなと。
・最短について
2 20 21 10
| | | |
1 -- 3 -- 4 -- 32 -- 5 -- 330
上記マップにおいて、1→20の経路をたどる際に人が見れば1-3-4-20とたどれると思いますが、
書き方によっては１-3-2-3-4-20のように2をわざわざ通ることも考えられると思い最短としました。
回路図であるため、基本的にはループするような図面にはなっていません。
このへんも前提を詳細に記載していれば誤解を生みませんでしたね。
・処理時間について
4時間経ってもゴールできなかったのは、私の処理させたマップにミスが会ったからでした。すみません。
mmさん：1529秒
tkitさん：0.97秒
モゲラさん：11.6秒
γさん：0.02秒
使用したマップは以下です。
シート1
1 300 55
1 301 115
2 300 100
3 302 89
4 305 150
5 329 164
6 326 99
7 331 115
8 332 91
9 371 65
10 336 133
11 336 134
12 372 40
13 340 80
14 343 160
15 343 90
16 345 130
17 345 75
18 310 168
19 348 111
20 348 95
21 348 143
22 350 169
23 302 150
25 354 89
26 352 144
27 352 127
28 359 75
29 359 91
30 359 168
31 362 185
32 362 102
33 361 60
34 310 100
36 364 217
37 364 184
38 368 70
38 369 133
39 319 80
40 320 110
41 320 80
42 320 115
43 320 115
44 322 80
46 324 103
47 324 96
48 365 85
49 365 93
50 348 154
55 320 182
300 410 115
301 300 60
301 303 114
302 301 64
303 302 50
304 303 72
304 307 730
305 304 45
305 325 135
305 395 96
306 53 106
306 305 45
306 333 69
307 306 40
307 309 115
308 307 78
308 344 70
309 308 45
309 311 110
310 309 70
310 361 165
310 397 150
311 373 80
312 311 118
312 315 258
313 312 40
313 400 90
314 400 59
315 314 45
315 317 80
316 315 40
317 316 30
318 317 90
319 318 40
320 319 108
320 391 115
320 404 180
321 320 50
321 323 75
322 321 40
323 322 35
324 323 40
325 326 40
325 327 190
327 326 150
328 327 190
328 330 156
329 328 40
329 330 116
330 7 170
330 331 60
332 331 85
333 334 40
333 335 145
334 335 100
335 336 40
336 9 160
336 371 100
337 334 95
337 339 180
338 12 135
338 337 140
339 338 40
339 341 125
340 339 40
341 340 85
342 341 68
343 342 40
344 345 40
347 310 120
347 349 130
348 347 60
348 392 150
349 348 70
349 351 90
350 349 50
351 350 40
352 351 40
352 353 250
352 399 110
353 354 40
353 355 140
354 355 102
354 398 130
355 24 80
359 399 40
360 310 120
361 360 40
362 361 50
363 313 80
364 363 40
365 366 40
366 306 100
368 369 60
369 314 150
372 338 100
373 310 10
374 305 130
374 375 40
374 395 30
375 51 95
375 52 85
376 377 110
377 384 80
377 393 90
377 403 180
378 377 80
379 377 100
380 377 90
381 377 95
383 377 170
385 384 230
386 384 155
387 384 50
388 387 40
389 388 80
318 388 50
シート2
372 375
373 376
374 377
374 377
374 1
375 378
375 379
399 380
310 381
360 300
1 300
1 301
1 301
2 300
3 302
4 377
5 374
（まる） 2022/01/25(火) 21:18
お疲れ様でした。
ところで、提示された元データは、 ・146のnode ・167のedge を持った無向グラフということになります。
この146個のnodeどうしのすべてについて、 その間の最短経路を計算する方法も知られています。 Floyd-Warshall法と呼ばれるものらしいです。 参考までに実装してみました。
【準備】 ・Sheet1シートのA:C列にグラフデータを置き、 ・Sheet2シートを用意し、 ・下記のコードを標準モジュールにコピーペイストしてください。
【出力】
・main2プロシージャを実行すると、
Sheet2の
[G1].Resize(147,147) に 各node間の最短距離
[EY1].Resize(147,147) に 各node間の最短経路の長さ
[KQ1].Resize(147,147) に 各node間の最短経路のパス
を出力します。
結果の精査はしていませんが、たぶんいけているのではと思います。
最長のパスは25個でした。
25パスのものは何個かありますが、例えば下記。
46 -> 324 -> 323 -> 321 -> 320 -> 319 -> 318 -> 317 -> 316 -> 315 -> 314 -> 400 ->
313 -> 312 -> 311 -> 309 -> 307 -> 306 -> 305 -> 325 -> 327 -> 328 -> 330 -> 331 -> 332 -> 8
処理時間は0.38秒でした。
■参考までにコードを示します。
Option Explicit Rem Floyd-Warshall法による全対最短経路(all pairs shortest paths)
Dim N As Long Const INF As Long = 99999 '最大値 Dim dic As Object Dim dicR As Object Dim dist() As Long Dim nextNode() Dim route() As String Dim pathLength() As Long
Dim ws As Worksheet Dim wsOut As Worksheet
Sub main2()
' Floyd_Warshallアルゴリズムによる全対最短経路
'（各node間の最短経路をすべて求めること）の算定です。
Dim t
t = Timer
Set ws = Worksheets("Sheet1") '■必要に応じて修正
Set wsOut = Worksheets("Sheet2") '■必要に応じて修正
Dim i&, j&, k&
Call setting2 '前提の設定
ReDim nextNode(1 To N, 1 To N)
For i = 1 To N
For j = 1 To N
nextNode(i, j) = IIf(j <> i, j, 0)
Next
Next
For k = 1 To N
For i = 1 To N
For j = 1 To N
If dist(i, k) + dist(k, j) < dist(i, j) Then
dist(i, j) = dist(i, k) + dist(k, j)
nextNode(i, j) = nextNode(i, k)
End If
Next
Next
Next
'最短経路文字列、最短経路の長さの算出
Call make_route(nextNode)
'結果表示（各node間の(1)最短距離と、(2)最短経路の長さ、(3)最短経路をシートに表示）
wsOut.Cells(1, 8).Resize(500, 3 * (N + 2)).ClearContents
'最短距離
wsOut.Cells(1, 8).Resize(1, N) = dic.keys
wsOut.Cells(2, 7).Resize(N, 1) = Application.Transpose(dic.keys)
wsOut.Cells(2, 8).Resize(N, N) = dist
wsOut.Cells(1, 8).Resize(1, N).EntireColumn.AutoFit
'最短経路のedgeの長さ
wsOut.Cells(1, 8 + N + 2).Resize(1, N) = dic.keys
wsOut.Cells(2, 8 + N + 1).Resize(N, 1) = Application.Transpose(dic.keys)
wsOut.Cells(2, 8 + N + 2).Resize(N, N) = pathLength
wsOut.Cells(1, 8 + N + 2).Resize(1, N).EntireColumn.AutoFit
'最短経路
wsOut.Cells(1, 8 + 2 * (N + 2)).Resize(1, N) = dic.keys
wsOut.Cells(2, 8 + 2 * (N + 2) - 1).Resize(N, 1) = Application.Transpose(dic.keys)
wsOut.Cells(2, 8 + 2 * (N + 2)).Resize(N, N) = route
wsOut.Cells(1, 8 + 2 * (N + 2)).Resize(1, N).EntireColumn.AutoFit
Debug.Print Timer - t; "Floyd-Warshall"
End Sub
Function setting2()
Dim s$, st$, ed$
Dim p&, j&, k&
Dim e
Set dic = CreateObject("Scripting.Dictionary")
Set dicR = CreateObject("Scripting.Dictionary")
' node番号と 整数インデックスとの相互変換をdictionaryに保持
For Each e In ws.[A1].CurrentRegion.Resize(, 2)
s = e.Value
If Not dic.Exists(s) Then
p = p + 1
dic(s) = p
dicR(p) = s
End If
Next
N = dic.Count 'nodeの数
ReDim dist(1 To N, 1 To N) '隣接行列
'いったん大きい数をセット
For j = 1 To N
For k = 1 To N
dist(j, k) = INF
Next
Next
For j = 1 To N
dist(j, j) = 0
Next
'隣接行列distの作成
For Each e In ws.[A1].CurrentRegion.Resize(, 1)
st = CStr(e.Value)
ed = CStr(e.Offset(, 1).Value)
dist(dic(st), dic(ed)) = e.Offset(, 2).Value
dist(dic(ed), dic(st)) = e.Offset(, 2).Value '無向グラフのため逆方向もセット
Next
End Function
Function make_route(nextNode)
Dim i&, j&, k&, u&
Dim path As String
' iからj への route の作成
ReDim route(1 To N, 1 To N) As String
ReDim pathLength(1 To N, 1 To N) As Long
For i = 1 To N
For j = 1 To N
If i <> j Then
u = i
path = dicR(i)
Do
u = nextNode(u, j)
path = path & " -> " & dicR(u)
If u = j Then
Exit Do
End If
Loop
route(i, j) = path
pathLength(i, j) = (Len(path) - Len(Replace(path, "->", ""))) / 2
End If
Next
Next
End Function
遊びで、GraphVizにグラフを書かせてみました。 結構きれいなグラフになりました。 指定した2点間のパスに色を付けるといいかな、などと思いました。 （γ） 2022/01/25(火) 22:47
指定したノード間をどの回路が通過しているか、
などといった情報を出力することにも利用できそうだなとも思いました。
正確さに関してはまだ確認が取れていませんが、
みなさまからいただいた知恵をもとに実装したいと思います。
（まる） 2022/01/31(月) 18:10
（γ） 2022/01/31(月) 20:52
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.