[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAにて最短距離探索』（にく）
A列（データ数） Ｂ列（番地） Ｃ列（番地） Ｄ列（Ｂ列とＣ列の距離）
１ １００ ２００ ５
２ １００ ３００ ４
３ ２００ ３００ ２
４ ２００ ４００ ６
５ ３００ ４００ ３
６ ２００ １００ ５
７ ３００ １００ ４
８ ３００ ２００ ２
９ ４００ ２００ ６
１０ ４００ ３００ ３
上記のような表があります。
１００番地から４００番地への最短距離を求めるマクロを考えたのですが
コードが汚くてうまく動きません。
どなたか、教えてください。
Sub SAITAN()
Dim HOZON(1000, 2)
Dim N
N = 1
Do Until N = 999
HOZON(N, 1) = 1000
HOZON(N, 0) = 0
HOZON(N, 2) = 0
N = N + 1
Loop
Dim START, ENDB, pointsuu
START = Cells(2, 6).Value
ENDB = Cells(2, 7).Value
pointsuu = Cells(2, 2).Value
Dim POINT, V
POINT = 0
HOZON(0, 0) = START
HOZON(0, 1) = 0
HOZON(0, 2) = START
For V = 1 To pointsuu + 1
Dim GYOU
GYOU = 5 'データの始まり。
Do Until GYOU = 83 'データの終わり。
If Cells(GYOU, 2) = START Then
Dim J, FLG, KPOINT
J = 0
FLG = 0
Do Until J = pointsuu + 1
If Cells(GYOU, 3) = HOZON(J, 0) Then
FLG = 1
KPOINT = J '今までに通ったことがある場所の格納位置を保存
End If
J = J + 1
Loop
If V = 3 Then
T = 100
End If
If FLG = 0 Then
HOZON(POINT + 1, 0) = Cells(GYOU, 3)
If HOZON(V - 1, 0) = HOZON(0, 0) Then
HOZON(POINT + 1, 1) = Cells(GYOU, 4)
Else
HOZON(POINT + 1, 1) = Cells(GYOU, 4) + HOZON(V - 1, 1)
End If
HOZON(POINT + 1, 2) = START
POINT = POINT + 1
Else
If HOZON(V - 1, 1) + Cells(GYOU, 4) < HOZON(KPOINT, 1) Then
Dim TR
TR = HOZON(KPOINT, 1) - HOZON(V - 1, 1) - Cells(GYOU, 4)
HOZON(KPOINT, 1) = HOZON(V - 1, 1) + Cells(GYOU, 4)
HOZON(KPOINT, 2) = HOZON(V - 1, 0)
'前ポイント検索して差額を引く
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
HH = 0
Do Until HH = pointsuu
If HOZON(HH, 2) = HOZON(KPOINT, 0) Then
HOZON(HH, 1) = HOZON(HH, 1) - TR
TTT = 0
Do Until TTT = pointsuu
If HOZON(TTT, 2) = HOZON(HH, 0) Then
HOZON(TTT, 1) = HOZON(TTT, 1) - TR
TTTS = 0
Do Until TTTS = pointsuu
If HOZON(TTTS, 2) = HOZON(TTT, 0) Then
HOZON(TTTS, 1) = HOZON(TTTS, 1) - TR
TTTSS = 0
Do Until TTTSS = pointsuu
If HOZON(TTTSS, 2) = HOZON(TTTS, 0) Then
HOZON(TTTSS, 1) = HOZON(TTTSS, 1) - TR
End If
TTTSS = TTTSS + 1
Loop
End If
TTTS = TTTS + 1
Loop
End If
TTT = TTT + 1
Loop
End If
HH = HH + 1
Loop
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
ElseIf HOZON(V - 1, 1) + Cells(GYOU, 4) = HOZON(KPOINT, 1) Then
End If
End If
End If
GYOU = GYOU + 1
Loop
START = HOZON(V, 0)
Next
Dim H
H = 1
Do Until HOZON(H, 0) = ENDB
H = H + 1
Loop
Cells(2, 8) = HOZON(H, 1)
For w = 1 To pointsuu
Cells(9, w + 8) = HOZON(w - 1, 0)
Cells(10, w + 8) = HOZON(w - 1, 1)
Cells(11, w + 8) = HOZON(w - 1, 2)
Next
End Sub
レスが付きませんね。 ＞１００番地から４００番地への最短距離 これはどのようなことでしょうか。 （川野鮎太郎）
簡単にいうとA地点からＺ地点迄どういったルートを通れば最短距離で進めるかを
出したいわけです。
使用するデータは、各地点の隣接する地点迄の距離だけです。
上記の例で言えば、１００番地から４００番地へ行くのに
１００番地から３００番地を通って４００番地へ行けば７ｋｍの最短でいける。
という答えを求めたいわけです。
よろしくお願いします。（にく）
説明が悪いと言うか、これはもう仕事的な話だと思った。
興味はあったので自分なりの方法を模索……提示されたマクロについては、あまり見てません。失礼。
この手の処理は再帰するとシンプルになる可能性あり、って事で参考にでも。
Option Explicit
Private Type typSerach
Route As String
Distance As Long
End Type
'ある範囲内における列配置
Private Enum menmCol
IDNo = 1 'キー
SVal = 2 'スタート位置
EVal = 3 'エンド位置
Distance = 4 '距離
End Enum
Sub test()
Dim udtSearch() As typSerach
Dim udtTemp As typSerach
Dim i As Integer
Dim strWk As String
ReDim udtSearch(0 To 0)
'ある範囲のデータを対象に、100から400への全ルートを検索
If Not fncSearch(Range("A1:D10"), "100", "400", udtSearch(), udtTemp) Then
strWk = "失敗"
Else '成功時
If UBound(udtSearch) = 0 Then
strWk = "該当なし"
Else
'最短距離を求める
udtTemp = udtSearch(LBound(udtSearch))
For i = LBound(udtSearch) To UBound(udtSearch) - 1
If udtTemp.Distance > udtSearch(i).Distance Then
udtTemp = udtSearch(i)
End If
Next
With udtTemp
strWk = "ヒット" & vbTab & "ルート：" & Mid(.Route, 2) & vbTab & "距離：" & .Distance
End With
End If
End If
MsgBox strWk
End Sub
Function fncSearch( _
ByRef Target As Range, _
ByVal SVal As String, _
ByVal EVal As String, _
ByRef udtSearch() As typSerach, _
ByRef udtTemp As typSerach, _
Optional ByVal CurrentRow As Long = 1, _
Optional ByVal ClassLevel As Long = 0 _
) As Boolean
On Error GoTo ErrorHandler
Dim Row As Long
Dim Col As Long
Dim STemp As String
Dim blnErr As Boolean
Dim blnDup As Boolean
Dim blnHit As Boolean
Dim strHit As String
Dim strWk As String
Dim udtLocal As typSerach
fncSearch = False
blnErr = False 'エラーフラグ
blnHit = False 'ヒットフラグ
blnDup = False '重複フラグ
For Row = CurrentRow To Target.Rows.Count
If ClassLevel = 0 Then '最初のループ時のみ初期化
strHit = ""
With udtTemp
.Route = ""
.Distance = 0
End With
End If
If CStr(Target(Row, menmCol.SVal).Value) = SVal Then 'スタート位置の一致
blnDup = False '初期化
'既に通ったルートか判断
With udtTemp
If InStr(.Route & strHit & ",", "," & Target(Row, menmCol.IDNo).Value & ",") > 0 Then
blnDup = True '通ったので重複
End If
End With
If Not blnDup Then '重複してないなら
If CStr(Target(Row, menmCol.EVal).Value) = EVal Then '目的地なら
blnHit = True 'ヒット
Else '違うなら
udtLocal = udtTemp '現状保持
'ルートおよび距離を足しこむ
With udtTemp
.Route = .Route & "," & Target(Row, menmCol.IDNo).Value
.Distance = .Distance + Target(Row, menmCol.Distance).Value
End With
'エンドをスタートとする場所をサーチ（再帰）
STemp = CStr(Target(Row, menmCol.EVal).Value)
If Not fncSearch(Target, STemp, EVal, udtSearch(), udtTemp, 1, ClassLevel + 1) Then
blnErr = True '問題発生
End If
udtTemp = udtLocal '現状復帰
End If
If blnErr Then '問題があったら抜ける
Exit For
End If
If blnHit Then 'ヒットしてたら
blnHit = False '初期化
strHit = strHit & "," & Target(Row, menmCol.IDNo).Value '既に通った場所として保持
udtSearch(UBound(udtSearch)) = udtTemp '結果の配列にセット
'結果に足しこみ
With udtSearch(UBound(udtSearch))
.Route = .Route & "," & Target(Row, menmCol.IDNo).Value
.Distance = .Distance + Target(Row, menmCol.Distance).Value
End With
'配列拡張
ReDim Preserve udtSearch(0 To UBound(udtSearch) + 1)
End If
End If
End If
Next
'問題が発生してないなら
If Not blnErr Then
fncSearch = True '成功
End If
ErrorHandler:
End Function
検証不足＆無駄なロジック含むかもだけど
これ以上時間かけるのは無理、てことで投げるだけ投げ……
（ご近所PG）スペルミスとか修正修正
早速試して見ました。
上記の例では、うまく動くのですが
ポイント数を20ポイントで試したら、ループから抜けてきませんでした。
ちなみにポイント数は、全部で1000ポイント程度あります。
上記のアルゴリズムを参考にがんばって見ます。(にく）
少し興味があるので、 差し支えなければそのポイント数20ポイントのデータを書いて見てもらえますか…… いや、回答できる保障は無いんですが、ループから抜けないと言うのが気になるので。 （ご近所PG）無視してくれてもOK 1 1 2 1 2 1 4 5 3 1 5 4 4 1 9 2 5 1 17 4 6 2 1 1 7 2 4 2 8 2 8 3 9 3 4 2 11 3 5 3 12 3 6 3 13 4 1 5 14 4 2 2 16 4 3 2 17 4 7 4 18 4 10 4 19 5 1 4 20 5 3 3 21 5 6 3 22 5 17 3 23 6 3 3 24 6 5 3 25 6 10 3 26 6 14 2 27 7 4 4 28 7 8 7 29 7 10 3 30 7 12 3 31 7 13 2 32 8 2 3 33 8 7 7 34 8 9 4 35 8 13 6 36 9 1 2 37 9 8 4 38 9 17 5 39 10 4 4 40 10 6 3 41 10 7 3 42 10 14 5 43 10 15 8 44 11 12 4 45 11 15 3 46 11 16 5 47 11 18 3 48 12 7 3 49 12 11 4 50 12 13 3 51 12 16 3 52 12 20 8 53 13 7 2 54 13 8 6 55 13 12 3 56 14 6 2 57 14 10 5 58 14 15 4 59 15 10 8 60 15 11 3 61 15 14 4 62 15 18 2 63 16 11 5 64 16 12 3 65 16 18 5 66 16 19 7 67 16 20 5 68 17 1 4 69 17 5 3 70 17 9 5 71 18 11 3 72 18 15 2 73 18 16 5 74 18 19 6 75 19 16 7 76 19 18 6 77 19 20 9 78 20 12 8 79 20 16 5 80 20 19 9 （にく）
爆発的にサーチ範囲が広がるから帰ってこないのね。 ちょっと調査する階層の深さを制限するように変更してみました。
想定
E1にスタート番号
F1にエンド番号
G1に階層
を入力する物とします。
階層は、数字が小さいほど早く処理が返ってきますが精度が落ちるよ、って感じで。
一応、小さい値から試してみてください。
5階層くらいなら現実的な時間で返ってくるかな？と……1000件で試したりしてないのでアレだけど。
こういう計算は文系プログラマな自分は苦手です。
どれくらいの階層までチェックすれば現実的に問題ないかとか、得意な人が考えてくれるかも。
Option Explicit
Private Type typSerach
Route As String
Distance As Long
End Type
'ある範囲内における列配置
Private Enum menmCol
IDNo = 1 'キー
SVal = 2 'スタート位置
EVal = 3 'エンド位置
Distance = 4 '距離
End Enum
Sub test()
Dim udtSearch() As typSerach
Dim udtTemp As typSerach
Dim i As Integer
Dim strWk As String
ReDim udtSearch(0 To 0)
'ある範囲のデータを対象に、全ルートを検索
If Not fncSearch(Range("A1:D78"), Range("E1").Value, Range("F1").Value, udtSearch(), udtTemp, Range("G1").Value) Then
strWk = "失敗"
Else '成功時
If UBound(udtSearch) = 0 Then
strWk = "該当なし"
Else
'最短距離を求める
udtTemp = udtSearch(LBound(udtSearch))
For i = LBound(udtSearch) To UBound(udtSearch) - 1
If udtTemp.Distance > udtSearch(i).Distance Then '距離が短い物を採用
udtTemp = udtSearch(i)
ElseIf udtTemp.Distance = udtSearch(i).Distance Then '距離が同じ場合
'より経路の短い物を採用
If UBound(Split(udtTemp.Route, ",")) > UBound(Split(udtSearch(i).Route, ",")) Then
udtTemp = udtSearch(i)
End If
End If
Next
With udtTemp
strWk = "ヒット" & vbTab & "ルート：" & Mid(.Route, 2) & vbTab & "距離：" & .Distance
End With
End If
End If
MsgBox strWk
End Sub
Function fncSearch( _
ByRef Target As Range, _
ByVal SVal As String, _
ByVal EVal As String, _
ByRef udtSearch() As typSerach, _
ByRef udtTemp As typSerach, _
Optional ByVal MaxClassLevel As Long = 5, _
Optional ByVal ClassLevel As Long = 0, _
Optional ByVal CurrentRow As Long = 1 _
) As Boolean
On Error GoTo ErrorHandler
Dim Row As Long
Dim Col As Long
Dim STemp As String
Dim blnErr As Boolean
Dim blnDup As Boolean
Dim blnHit As Boolean
Dim strHit As String
Dim strWk As String
Dim udtLocal As typSerach
fncSearch = False
blnErr = False 'エラーフラグ
blnHit = False 'ヒットフラグ
blnDup = False '重複フラグ
'ある一定階層以上のサーチを要する場合はあきらめる
If ClassLevel >= MaxClassLevel Then
GoTo ExitHandler
End If
For Row = CurrentRow To Target.Rows.Count
If ClassLevel = 0 Then '最初のループ時のみ初期化
strHit = ""
With udtTemp
.Route = ""
.Distance = 0
End With
End If
If CStr(Target(Row, menmCol.SVal).Value) = SVal Then 'スタート位置の一致
blnDup = False '初期化
'既に通ったルートか判断
With udtTemp
If InStr(.Route & strHit & ",", "," & Target(Row, menmCol.IDNo).Value & ",") > 0 Then
blnDup = True '通ったので重複
End If
End With
If Not blnDup Then '重複してないなら
If CStr(Target(Row, menmCol.EVal).Value) = EVal Then '目的地なら
blnHit = True 'ヒット
Else '違うなら
udtLocal = udtTemp '現状保持
'ルートおよび距離を足しこむ
With udtTemp
.Route = .Route & "," & Target(Row, menmCol.IDNo).Value
.Distance = .Distance + Target(Row, menmCol.Distance).Value
End With
'エンドをスタートとする場所をサーチ（再帰）
STemp = CStr(Target(Row, menmCol.EVal).Value)
If Not fncSearch(Target, STemp, EVal, udtSearch(), udtTemp, MaxClassLevel, ClassLevel + 1) Then
blnErr = True '問題発生
End If
udtTemp = udtLocal '現状復帰
End If
If blnErr Then '問題があったら抜ける
Exit For
End If
If blnHit Then 'ヒットしてたら
blnHit = False '初期化
strHit = strHit & "," & Target(Row, menmCol.IDNo).Value '既に通った場所として保持
udtSearch(UBound(udtSearch)) = udtTemp '結果の配列にセット
'結果に足しこみ
With udtSearch(UBound(udtSearch))
.Route = .Route & "," & Target(Row, menmCol.IDNo).Value
.Distance = .Distance + Target(Row, menmCol.Distance).Value
End With
'配列拡張
ReDim Preserve udtSearch(0 To UBound(udtSearch) + 1)
End If
End If
End If
Next
ExitHandler:
'問題が発生してないなら
If Not blnErr Then
fncSearch = True '成功
End If
ErrorHandler:
End Function
追記： データの並び規則をルーチンに加味すれば、もうちょっと軽くなる……とは思うけど、そこまではちょっとキツイ。 （ご近所PG）
>文系プログラマな自分は苦手です。 そうなんだ～。 理系出身でもお遊びプログラマの私には再帰ロジックを考える脳みそはありませぬ･･･ ところで対象データの重複は削除したらまずいのかな・・ (INA)
お勉強は理系の方だったんですが、向いてなかったかも。 頭の中は文系っぽいなぁと個人的に思ってたり。どうも文章的なコードになる。
私的イメージ 文系PG「これがこうだったらあーして、そうでなかったらこうして、結果どうなったかを返しなさい」 理系PG「１と２で３」
っていう感じ？（なんだそりゃ） コーディング量と言う面とかの効率が悪いみたいな。 どちらが良いって訳でもないけど。
追記： 重複は逆引きできるって事で用意してるのかしらと。20→1でも同じルーチンで探せる。 B列がきれいに並んでいる前提で考えるならば Excel機能でMatchだかをかましてスタート位置取得、違う値になったら抜ける。 ってするだけで相当に軽くなるとは思う。 （ご近所PG）SQLでwhereかまして必要な部位だけ見るようなイメージ
自己満足更新アップ。
B列の値が同値でまとまっている事を前提として、処理速度改善を図った物です。
前述のものは「全ポイント行数」に多大に影響を受ける作りでしたが、
今回のものは「1ポイント当たりの行数」に影響を受ける作りです。
これにより20ポイント分のデータだろうが、1000ポイント分のデータだろうが、
（すなわち1ポイント当たり4行程と考えた場合、20ポイントで80行、1000ポイントで4000行のデータ、そのどちらでも）
処理時間が平均的になるはず。多分。
使用前提
A:Dに検索用データが入力されている事
E1にスタート番号を入力する事
F1にエンド番号を入力する事
G1に階層を入力する事
検索値は数値扱いできる物に限られている事
（HとIに結果を吐き出す動きを入れたがコメント扱い……内容を見たいならコメント外す）
Option Explicit
Private Type typSerach
Route As String
Distance As Long
End Type
'ある範囲内における列配置
Private Enum menmCol
IDNo = 1 'キー
SVal = 2 'スタート位置
EVal = 3 'エンド位置
Distance = 4 '距離
End Enum
Sub test()
Dim udtSearch() As typSerach
Dim udtTemp As typSerach
Dim i As Integer
Dim strWk As String
ReDim udtSearch(0 To 0)
'ある範囲のデータを対象に、全ルートを検索
If Not fncSearch(Range("A:D"), Range("E1").Value, Range("F1").Value, udtSearch(), udtTemp, Range("G1").Value) Then
strWk = "失敗"
Else '成功時
If UBound(udtSearch) = 0 Then
strWk = "該当なし"
Else
'最短距離を求める
udtTemp = udtSearch(LBound(udtSearch))
For i = LBound(udtSearch) To UBound(udtSearch) - 1
'ヒット内容をH列とI列に出力
'Range("H" & CStr(i + 1)).Value = Mid(udtSearch(i).Route, 2)
'Range("I" & CStr(i + 1)).Value = udtSearch(i).Distance
If udtTemp.Distance > udtSearch(i).Distance Then '距離が短い物を採用
udtTemp = udtSearch(i)
ElseIf udtTemp.Distance = udtSearch(i).Distance Then '距離が同じ場合
'より経路の短い物を採用
If UBound(Split(udtTemp.Route, ",")) > UBound(Split(udtSearch(i).Route, ",")) Then
udtTemp = udtSearch(i)
End If
End If
Next
With udtTemp
strWk = "ヒット数：" & UBound(udtSearch) & vbCrLf & "最短ルート：" & Mid(.Route, 2) & vbCrLf & "距離：" & .Distance
End With
End If
End If
MsgBox strWk
End Sub
Function fncSearch( _
ByRef Target As Range, _
ByVal SVal As String, _
ByVal EVal As String, _
ByRef udtSearch() As typSerach, _
ByRef udtTemp As typSerach, _
Optional ByVal MaxClassLevel As Long = 5, _
Optional ByVal ClassLevel As Long = 0, _
Optional ByVal CurrentRow As Long = 1 _
) As Boolean
On Error GoTo ErrorHandler
Dim Row As Long
Dim STemp As String
Dim blnErr As Boolean
Dim blnDup As Boolean
Dim blnHit As Boolean
Dim strHit As String
Dim udtLocal As typSerach
Dim StartRow As Long
fncSearch = False
blnErr = False 'エラーフラグ
blnHit = False 'ヒットフラグ
blnDup = False '重複フラグ
'ある一定階層以上のサーチを要する場合はあきらめる
If ClassLevel >= MaxClassLevel Then
GoTo ExitHandler
End If
On Error Resume Next
'対象シートの同値の行を取得
StartRow = WorksheetFunction.Match(CLng(SVal), Target.Columns(menmCol.SVal), 0)
If Err Then
StartRow = -1
Err.Clear
End If
On Error GoTo ErrorHandler
If StartRow = -1 Then
GoTo ExitHandler
End If
For Row = StartRow To Target.Rows.Count
If ClassLevel = 0 Then '最初のループ時のみ初期化
strHit = ""
With udtTemp
.Route = ""
.Distance = 0
End With
End If
'スタート位置の不一致
If CStr(Target(Row, menmCol.SVal).Value) <> SVal Then
Exit For '抜ける
End If
blnDup = False '初期化
'既に通ったルートか判断
With udtTemp
If InStr(.Route & strHit & ",", "," & Target(Row, menmCol.IDNo).Value & ",") > 0 Then
blnDup = True '通ったので重複
End If
End With
If Not blnDup Then '重複してないなら
If CStr(Target(Row, menmCol.EVal).Value) = EVal Then '目的地なら
blnHit = True 'ヒット
Else '違うなら
udtLocal = udtTemp '現状保持
'ルートおよび距離を足しこむ
With udtTemp
.Route = .Route & "," & Target(Row, menmCol.IDNo).Value
.Distance = .Distance + Target(Row, menmCol.Distance).Value
End With
'エンドをスタートとする場所をサーチ（再帰）
STemp = CStr(Target(Row, menmCol.EVal).Value)
If Not fncSearch(Target, STemp, EVal, udtSearch(), udtTemp, MaxClassLevel, ClassLevel + 1) Then
blnErr = True '問題発生
End If
udtTemp = udtLocal '現状復帰
End If
If blnErr Then '問題があったら抜ける
Exit For
End If
If blnHit Then 'ヒットしてたら
blnHit = False '初期化
strHit = strHit & "," & Target(Row, menmCol.IDNo).Value '既に通った場所として保持
udtSearch(UBound(udtSearch)) = udtTemp '結果の配列にセット
'結果に足しこみ
With udtSearch(UBound(udtSearch))
.Route = .Route & "," & Target(Row, menmCol.IDNo).Value
.Distance = .Distance + Target(Row, menmCol.Distance).Value
End With
'配列拡張
ReDim Preserve udtSearch(0 To UBound(udtSearch) + 1)
End If
End If
Next
ExitHandler:
'問題が発生してないなら
If Not blnErr Then
fncSearch = True '成功
End If
ErrorHandler:
End Function
（ご近所PG）ロジック自体の無駄とか見直しはしてない
某、大阪の大学経済学部経済学科卒ばりばりの文化系
お遊びPG、、別名「マクロの記録王」。。。。
ちょっと、作ってみました。。。
でも、あってるかどうかわかりません。
これ以上を求められてもお返事出来るかどうかわかりません。
単なる自己満足です。。。
題して、、、「私なら、、偏」です。
Option Explicit
Dim MyMin As Long
Dim MyMax As Long
Dim k As Long
Dim MyDis As String
Sub てすと()
Dim MyA As Variant
Dim MyTbl As Range
Dim MyKey As String, x As Long
Dim i As Long, z As Long
Dim MySS As String
With Worksheets("Sheet1")
Set MyTbl = .Range("A1", .Range("A65536").End(xlUp))
End With
'データを配列に取得
MyA = MyTbl.Resize(, 3).Value
'スタートのポイントを取得
MyMin = Application.Min(MyTbl)
'ゴールのポイントを取得
MyMax = Application.Max(MyTbl.Resize(, 1).Offset(, 1))
'カウンターの初期化
k = 0
'ループの開始
For i = 1 To UBound(MyA, 1)
MyDis = Empty
'スタート地点だったら
If MyA(i, 1) = MyMin Then
MyKey = MyA(i, 2)
x = MyA(i, 3)
'MySEARCHにキーと距離を渡して探索開始
MySEARCH MyKey, MyTbl, x
'初めて成功した値を取得
If k = 1 And MyKey = MyMax Then
z = x
MySS = MyMin & MyDis
End If
'ゴールまで行けたら
If MyKey = MyMax Then
'前回と比較して小さかったらzを更新
If x < z Then
z = x
MySS = MyMin & MyDis
End If
End If
End If
Next
'探索に成功していたら
If k > 0 Then
MsgBox "最短ルートは" & MySS & Chr(13) & _
"最短距離は" & z & "でちゅv(=∩_∩=)v。。。"
Else
MsgBox "探索出来ませんでした。。"
End If
Erase MyA
Set MyTbl = Nothing
End Sub
Sub MySEARCH(ByRef MyData As String, ByVal MyRng As Range, ByRef x As Long)
Dim MyB As Variant
Dim j As Long
MyB = MyRng.Resize(, 3).Value
For j = 1 To UBound(MyB, 1)
'次のポイントだったら
If MyB(j, 1) = Val(MyData) Then
'前進したら
If MyB(j, 2) > Val(MyData) Then
MyDis = MyDis & ":" & MyData & ":" & MyB(j, 2)
'現在の距離にプラスして更新
x = x + MyB(j, 3)
'ポントを更新
MyData = MyB(j, 2)
'最終地点まで行けたら
If Val(MyData) = MyMax Then
'カウンターの更新
k = k + 1
'ループを抜ける
Exit For
End If
End If
End If
Next
Erase MyB
End Sub
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0248.xls
すみません。わかりました。自分でデータを改ざんしてました。（￣□￣；）！！
お騒がせしました。m(._.)m ペコッ
ありゃ、よく見たらABCD列ですかぁ、、、A列は番号だけだから関係ないんでしょ？
私はABCしかみてませんので
BCD列にしたい時は、お分かりでしょうけど、、↓これを
Set MyTbl = .Range("A1", .Range("A65536").End(xlUp))
これに↓
Set MyTbl = .Range("B1", .Range("B65536").End(xlUp))
に変更してください。ではでは、おやすみなさいzzzzzzzz
（SoulMan）
自分もちょろりと補足してみよう。 私のマクロが返す最短ルートの値は、A列の値です。 A列の値をいわゆる主キーとして見ています。 A列の値に重複が無い前提とした時に重複チェックがしやすいと言う利点があったので。 たとえば示していただいた20ポイントのデータをA:D列に貼り付けた上で、 探索の条件として、以下のような指定をしてみる。 E1を 8（スタート位置） F1を16（エンド位置） G1を 5（階層） すると、以下のような結果を返す。 ヒット数 ：35 最短ルート：35,55,51 距離 ：12 これの見方は、8から16へ向かうルートが5階層までで見たときに35パターンあり、 その道筋の中でA列が 35のデータ（ 8→13,距離6） 55のデータ（13→12,距離3） 51のデータ（12→16,距離3） といった道筋を辿ると、最も距離が短いですよ、と。 つまり書き換えると 8→13→12→16 と行くと最も距離が短い。はず。 そんな感じ。
ちなみに1から20へのルートは、 4階層で見たときに ヒット数 ：1 最短ルート：2,17,30,52 距離 ：20 5階層で見たときに ヒット数 ：9 最短ルート：1,7,17,30,52 距離 ：18 8階層で見たときにも ヒット数 ：1094 最短ルート：1,7,17,30,52 距離 ：18 と言った結果となりました。 書き換えると 1→2→4→7→12→20 かな。 SoulManさんのマクロも詳細に見たいけど眠い…… （ご近所PG）＆ちと最近忙しい
あまえついでにもう一つお願いしたいんですが、
なにをやりたいかと言うと、ある工場からすべてのポイントへの運賃距離表
を作成したいわけなんです。ですからスタート地点を登録して
スタート地点よりすべてのポイントへの最短距離及び一つ前のポイントが
記された表を作成したいのですが・・・。
無視してくれてもokです。甘えすぎかも？（にく）
考え方だけ。 もし自分提示の上記マクロの動作結果に問題が無いと思われるならば、それを元に改良してみる。 現状では「スタート地点」と「エンド地点」が単一セルを見る形で作ってますが、 それを全ポイント分繰り返すような作りにしてみてはどうでしょう。 「一つ前のポイント」については、ヒットした最後の場所のデータを見れば分かるはずです。 それは容易に取得出来るでしょう。 （ご近所PG）と言うことで
＞もし自分提示の上記マクロの動作結果に問題が無いと思われるならば、それを元に改良してみる。
問題ありです。距離が同一の時の処理が出来ていないし、
最短距離が更新された時に、その他のポイントをいったいどこまで
遡って修正すれば、正確な値がでてくるのか？ですし、その他にもあるかも・・
ということで（ご近所PG）さんのマクロをループさせて処理を完了したいと思います。
仕事 終了です。
長々と有難うございました。（にく）ペコッ
解決済でしかもご近所PGさんのマクロでも問題ありの様ですので、
私のなんかは比じゃありませんが、一応例題の分（100から400）と（1から20）
だけでもやっておきたっかたので、までやってました。。
でも、結局、今の私の力では無理のようです。
遅いし、精度悪いし、、お遊びではこれが限界かもしれません。。
いつか出来るようになるまで精進！精進！！です。
しかし、、難しいね、、これ(ｰｰ;)
ではでは、板汚しですが、お許しください。。m(._.)m ペコッ
Option Explicit
Dim MyDic As Object
Dim MyA As Variant
Dim MyDis As String
Dim MyStart As Long, MyEnd As Long
Sub てすと()
'**********************************************
'変数の宣言
Dim MyAry() As Variant, MyAryA() As Variant
Dim i As Long, z As Long, n As Long, kk As Long
Dim MyKey As Long, x As Long, t As Long, dd As Long
Dim MyTbl As Range
Dim MySCount As Long, MyECount As Long
Dim w As Variant, ww As String
'***********************************************
Application.ScreenUpdating = False
With Worksheets("Sheet1")
Set MyTbl = .Range("A1", .Range("A65536").End(xlUp))
Set MyDic = CreateObject("Scripting.Dictionary")
'作業列のクリア
.Range("E1").EntireColumn.ClearContents
'データを配列に取得
MyA = MyTbl.Resize(, 5).Value
'スタートの位置を取得
MyStart = .Range("F1").Value
'ゴールの位置を取得
MyEnd = .Range("G1").Value
' MySCountを初期化
MySCount = Empty
kk = 1
Do
Do
MySCount = Application.WorksheetFunction.Count(MyTbl.Resize(, 1).Offset(, 4))
For i = kk To UBound(MyA, 1)
'スタート地点だったら
If MyA(i, 2) = MyStart Then
'前進するポイントだったら
If MyA(i, 2) < Val(MyA(i, 3)) Then
'ゴールじゃなかったら
If MyA(i, 3) <> MyEnd Then
'スタートポイント
MyDis = MyA(i, 2)
'次のポイント
MyKey = MyA(i, 3)
'距離
z = MyA(i, 4)
'次のポイントと距離をMySEARCHに渡して探索
MySEARCH MyKey, z
Else 'ゴールだったら
'MyDisに登録
MyDis = MyA(i, 2) & "," & MyA(i, 3)
x = MyA(i, 4)
'重複していなかったらMyDicに追加
If Not MyDic.Exists(MyDis) Then
MyDic.Add MyDis, x
End If
'ループを抜ける
Exit For
End If
End If
Else 'スタート地点じゃなかったら
'前進するポイントだったら
If MyA(i, 2) < Val(MyA(i, 3)) Then
'ゴールじゃなかったら
If MyA(i, 3) <> MyEnd Then
'スタートポイント
MyDis = MyA(i, 2)
'次のポイント
MyKey = MyA(i, 3)
'距離
z = MyA(i, 4)
'次のポイントと距離をMySEARCHに渡して探索
MySEARCH MyKey, z
Else 'ゴールだったら
'MyDisに登録
MyDis = MyA(i, 2) & "," & MyA(i, 3)
x = MyA(i, 4)
'重複していなかったらMyDicに追加
If Not MyDic.Exists(MyDis) Then
MyDic.Add MyDis, x
End If
'ループを抜ける
Exit For
End If
End If
End If
Next
MyECount = Application.WorksheetFunction.Count(MyTbl.Resize(, 1).Offset(, 4))
Loop While MySCount < MyECount '新しいルートが見つからないまでループ
'作業列のクリア
.Range("E1").EntireColumn.ClearContents
'ループカウンターをUP
kk = kk + 1
Loop While kk < UBound(MyA, 1) 'ここの条件をゆるくすれば早くなるが精度は落ちる
'探索結果を取得
w = MyDic.Keys
For i = LBound(w) To UBound(w)
'スタートのポイントを取得
ww = Left(w(i), InStr(1, w(i), ",") - 1)
'スタートのポイントじゃなかったら
If ww <> MyStart Then
'MyAの上限までループ
For n = 1 To UBound(MyA, 1)
'スタートとつながったらMyAryに代入
If MyA(n, 2) = MyStart And MyA(n, 3) = Val(ww) Then
t = t + 1
ReDim Preserve MyAry(1 To 2, 1 To t)
MyAry(1, t) = MyA(n, 2) & "," & w(i)
MyAry(2, t) = MyA(n, 4) + MyDic(w(i))
Exit For
End If
Next
Else 'スタートのポイントはそのまま代入
t = t + 1
ReDim Preserve MyAry(1 To 2, 1 To t)
MyAry(1, t) = w(i)
MyAry(2, t) = MyDic(w(i))
End If
Next
'作業列をクリア
.Range("E1").EntireColumn.ClearContents
'配列MyAを用意
ReDim MyAryA(1 To 1, 1 To 2)
'データがあったら
If t > 0 Then
'ddにダミーを代入
dd = 100000000
'MyAryの上限までループ
For i = LBound(MyAry, 2) To UBound(MyAry, 2)
'前回より小さかったら
If MyAry(2, i) < dd Then
'行列を入替えてMyAryAに代入
MyAryA(1, 1) = MyAry(1, i)
MyAryA(1, 2) = MyAry(2, i)
'ddを更新
dd = MyAry(2, i)
End If
Next
'結果をSheet2に書き出す
With Worksheets("Sheet2")
.Cells.Clear
.Range("A1").Resize(t, 2).Value = Application.Transpose(MyAry)
.Range("C1:D1").Value = MyAryA
.Range("A1:D1").EntireColumn.AutoFit
End With
MsgBox "最短ルートは" & MyAryA(1, 1) & Chr(13) & Chr(13) & _
"最短距離は" & MyAryA(1, 2) & "です。。"
Else
MsgBox "検索できませんでした。。"
End If
End With
Application.ScreenUpdating = True
'変数の初期化
Erase MyA, MyAry, MyAryA, w
Set MyDic = Nothing
Set MyTbl = Nothing
End Sub
Sub MySEARCH(ByRef MyData As Long, x As Long)
Dim j As Long
For j = 1 To UBound(MyA, 1)
'初めての次のポイントだったら
If MyA(j, 2) = MyData And Cells(j, 5) = "" Then
MyA(j, 5) = 1
Cells(j, 5) = 1
'後退したらループを抜ける
If MyA(j, 2) > MyA(j, 3) Then Exit For
'前進したらルートに追加していく
MyDis = MyDis & "," & MyData & "," & MyA(j, 3)
'現在の距離にプラスして更新
x = x + MyA(j, 4)
'ポントを更新
MyData = MyA(j, 3)
'最終地点まで行けたら
If Val(MyData) = MyEnd Then
'重複していなかったらMyDicに追加
If Not MyDic.Exists(MyDis) Then
MyDic.Add MyDis, x
End If
'ループを抜ける
Exit For
End If
End If
Next
End Sub
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0250.xls
（SoulMan）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.