Results of 1 - 1 of about 37655 for IF (0.007 sec.)
- [[20050219161833]]
- #score: 1592
- @digest: 9028ef5ba9ca133f268155947990e380
- @id: 12198
- @mdate: 2005-02-25T22:27:30Z
- @size: 38514
- @type: text/plain
- #keywords: udtsearch (407359), udttemp (314314), menmcol (227041), distance (171705), hozon (140291), typserach (129842), fncsearch (109858), route (100127), mydis (95375), blndup (89267), strhit (87886), classlevel (81828), blnhit (81198), blnerr (81198), udtlocal (68030), pointsuu (65915), 短ル (59046), 最短 (51317), mysearch (49302), 短距 (47828), strwk (36639), 距離 (36371), eval (33837), 地点 (21022), ト位 (15584), mytbl (14424), 探索 (13417), ポイ (11518), 階層 (10266), ヒッ (9103), らif (8530), myary (8516)
- 『VBAにて最短距離探索』（にく）
シートに A列（データ数） B列（番地） C列（番地） D列（B列とC列の距離） 1 100 200 5 2 100 300 4 3 200 300 2 4 200 400 6 5 300 400 3 6 200 100 5 7 300 100 4 8 300 200 2 9 400 200 6 10 400 300 3 上記のような表があります。 100番地から400番地への最短距離を求めるマクロを考えたのですが コードが汚くてうまく動きません。 どなたか、教えてください。 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 ---- レスが付きませんね。 ＞100番地から400番地への最短距離 これはどのようなことでしょうか。 （川野鮎太郎） ------------ 川野さん 返答ありがとうございます 説明が悪かったようです。 簡単にいうとA地点からZ地点迄どういったルートを通れば最短距離で進めるかを 出したいわけです。 使用するデータは、各地点の隣接する地点迄の距離だけです。 上記の例で言えば、100番地から400番地へ行くのに 100番地から300番地を通って400番地へ行けば7kmの最短でいける。 という答えを求めたいわけです。 よろしくお願いします。（にく） ---- 説明が悪いと言うか、これはもう仕事的な話だと思った。 興味はあったので自分なりの方法を模索……提示されたマクロについては、あまり見てません。失礼。 この手の処理は再帰するとシンプルになる可能性あり、って事で参考にでも。 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「1と2で3」 っていう感じ?（なんだそりゃ） コーディング量と言う面とかの効率が悪いみたいな。 どちらが良いって訳でもないけど。 追記: 重複は逆引きできるって事で用意してるのかしらと。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）&ちと最近忙しい --------- （ご近所PG）さん、（SoulMan）さん、 回答ありがとうございます。 あまえついでにもう一つお願いしたいんですが、 なにをやりたいかと言うと、ある工場からすべてのポイントへの運賃距離表 を作成したいわけなんです。ですからスタート地点を登録して スタート地点よりすべてのポイントへの最短距離及び一つ前のポイントが 記された表を作成したいのですが・・・。 無視してくれても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）... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/200502/20050219161833.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97039 documents and 608037 words.
訪問者：