Results of 1 - 1 of about 19648 for 20�����������������������... (0.004 sec.)
- [[20220119105630]]
- #score: 2682
- @digest: 39d3c40b30ddce3ac6c0352b81123ef2
- @id: 90193
- @mdate: 2022-01-31T11:52:36Z
- @size: 29870
- @type: text/plain
- #keywords: 短経 (94731), route (79048), routedic (64439), 最短 (64146), nextnode (57279), passed (57129), wsout (53039), pointer (51092), isgool (48690), distance (46067), 経路 (44254), timeout (38155), 迷路 (31084), rout (29955), node (29315), 接行 (26606), dist (24668), 回路 (20860), 距離 (14055), 隣接 (8584), ゴー (7529), start (6090), temp (4962), cstr (4040), ary (4034), dictionary (3752), scripting (3523), function (3520), dic (3485), ubound (3444), resize (3278), ドレ (3267)
- 『最短経路探索をしたいです。』（まる）
最短経路探索をしたいです。 各アドレス(分岐点や行き止り点)に番号が付与されており、 アドレス間には距離が設定されています。 アドレスの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 ＞ ---- Sub main() '作業用シートとしてSheet3を設置すること 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 ---- | 実際は50回程度の足し算が必要になるほどの迷路の大きさになっており、 | Start-Goalの個数も100個を超えるため、 その大きい場合の実例を出してもらうと取り組みやすいですね。 （γ） 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 'pを経由してkに至る長さがそれまでの最短路より小さい時は更新する 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 ---- 質問者さんへ 後学のために、それぞれ提示してあるコードで、 処理時間を教えてください。 サンプル迷路1つで構いません。 （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とたどれると思いますが、 書き方によっては1-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 ---- Floyd-Warshall法をコードにしていただき、ありがとうございました。 指定したノード間をどの回路が通過しているか、 などといった情報を出力することにも利用できそうだなとも思いました。 正確さに関してはまだ確認が取れていませんが、 みなさまからいただいた知恵をもとに実装したいと思います。 （まる） 2022/01/31(月) 18:10 ---- 実行時間というよりも、まずは結果の正しさでしょうからね。 もう実行済みかと思っていました。 （γ） 2022/01/31(月) 19:10 ---- まあ、確かに工業製品の製作なので、 見知らぬ人が書いたコードをそのまま使うわけには いかないかもしれませんね。 何かあっても、あなたが責任を負わないといけなくなりますしね。 仮に既存のアルゴリズムを使うだけであっても、 関係者に与える信用というのも大事でしょうから、 それなりにお金を掛けてみてはどうですか? そういう意味では、こうしたところで質問すること自体が 余り良い選択ではなかったでしょう。 （γ） 2022/01/31(月) 20:52... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202201/20220119105630.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97022 documents and 608152 words.
訪問者：