以前、この場で巡回セールスマン問題の考え方を使って、ということで質問に答えていただきました。その節はありがとうございました。
建築の学生なのですが、卒論の対象地の一つの分析として次のようなことを行っております。

対象地に14の交差点があって
「14の交差点全てを一筆書きで、最短経路で通過したい。」
ということをやるようになってます。
これに関して数人の方の協力でプログラムを組んでもらいました。
 
現在のプログラムはスタートのみ固定して、14それぞれ最短経路を探索し、ルートと最短距離を表示します。

今度はこれを、スタートとゴールともに固定して
「スタートが交差点1で、ゴールが交差点14のとき
 ルートは・・。最短距離は何m。」

というふうに表示させたいのですが、プログラムに関して私はまったく素人でどのように変更すればよいかわかりません。
そこで、どのように改良すればよいか教えていただけないでしょうか。
よろしくお願いします。
文字数の関係で、プログラムをのせれないのでお答えになってくださったときにお礼の場でプログラムをお見せすることができます。

このQ&Aに関連する最新のQ&A

A 回答 (3件)

結構手間がかかりそうなので、今日は全くプログラムを見てませんでした。


それじゃなくてもオリジナルの関数が多くて、コードを追いずらいです。

ぼくもやっては見ますけど、、、ムズイ、、、

とりあえず、ここの内容を見た人がやりやすいように、コメント位置をずらして、インデントしておきました。


この書き込みには基本的にはレス不要です。
nintaiさんが「ここら辺だと思う」というところがあったら補足してください。



Option Explicit

Public nPoint      As Integer '交差点の数
Public dist(20, 20)   As Integer '距離を入れておくテーブル
Public availRoad(20, 20) As Boolean '片道通過可能テーブル 既に通ったかどうかを記録
Public availPoint(20)  As Boolean '交差点通過可能配列 交差点を既に通ったかどうかを記録
Public checkPoint(20)  As Integer '交差点通過回数配列
Public move       As Integer '現在作りかけの経路の通過する交差点の延べ数
Public route(50)    As Integer '現在作りかけの経路
Public distance     As Integer '現在作りかけの経路の距離
Public minRoute(50)   As Integer 'これまでに見つかった最短経路
Public minMove     As Integer 'これまでに見つかった最短経路の通過する交差点の延べ数
Public minDistance   As Integer 'これまでに見つかった最短経路の距離
Public startPt     As Integer '出発交差点

'一筆経路探索(一度通過した交差点は通らない)
Sub SearchMove()
  Dim startStt As Integer '出発点の開始交差点番号
  Dim StartEnd As Integer '出発点の終了交差点番号

  'メッセージ表示
  Call ShowMsg("一筆探索 実行中")

  '結果削除
  Call ClearResult

  '道のデータを読み取る。
  Call GetRoadTable
  
  '通行可能交差点初期設定
  Call ClearAvailablePoint

  '検索
  Call GetStartPoint(startStt, StartEnd) '出発点の範囲取得
  minDistance = 30000 '大きな数値を入れておく
  
  For startPt = startStt To StartEnd
    Call ShowMsg("一筆探索 実行中 出発点" + Str(startPt))
    '出発点通過するので通過不可能にする
    availPoint(startPt) = False
    'ルートの履歴設定
    route(1) = startPt
    '出発点startPtから経路検索
    Call SearchMoveRepeat(startPt, 0, 1)
    '通過可能に戻す
    availPoint(startPt) = True
  Next startPt
  '結果表示
  Call ShowResult
  
  'メッセージ表示
  Call ShowMsg("一筆探索 終了")

End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
Sub SearchReturn()
  Dim startStt As Integer '出発点の開始交差点番号
  Dim StartEnd As Integer '出発点の終了交差点番号

  'メッセージ表示
  Call ShowMsg("一巡探索 実行中")

  '結果削除
  Call ClearResult
  
  '道のデータを読み取る。
  Call GetRoadTable
  
  '通行可能片道初期設定 & 通過交差点初期設定
  ClearAvailableRoad
  
  '検索
  Call GetStartPoint(startStt, StartEnd) '出発点の範囲取得
  '大きな数値を入れておく
  minDistance = 30000
  For startPt = startStt To StartEnd
    Call ShowMsg("一巡探索 実行中 出発点" + Str(startPt))
    'ルートの履歴設定
    route(1) = startPt
    '出発点1回通過済み
    checkPoint(startPt) = 1
    '出発点startPtから経路検索
    Call SearchReturnRepeat(startPt, 0, 1)
    '出発点を未通過に戻す
    checkPoint(startPt) = 0
  Next startPt
  '結果表示
  Call ShowResult
  
  'メッセージ表示
  Call ShowMsg("一巡探索 終了")

End Sub


'一筆経路探索(一度通過した交差点は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchMoveRepeat(curPt As Integer, distance As Integer, move As Integer)
  Dim branch As Integer '分岐
  Dim nextPt As Integer '次交差点
  Dim k    As Integer

  For branch = 1 To nPoint - 1
    '次交差点番号
    nextPt = (curPt + branch - 1) Mod nPoint + 1
    '次交差点通過可能の場合
    If availPoint(nextPt) Then
      '現在の最短距離を越えたら、その先を調べる必要なし。
      If minDistance > distance + dist(curPt, nextPt) Then
        '次交差点を通過するので通過不可能にする
        availPoint(nextPt) = False
        'ルートの履歴設定
        route(move + 1) = nextPt
        'まだ全交差点を回っていない
        If move + 1 < nPoint Then
          '経路を延ばす。
          Call SearchMoveRepeat(nextPt, distance + dist(curPt, nextPt), move + 1)
        '全交差点を回っている場合最短記録更新。
        Else
          '全距離
          minDistance = distance + dist(curPt, nextPt)
          '全交差点数
          minMove = move + 1
          '全ルート履歴
          For k = 1 To minMove
            minRoute(k) = route(k)
          Next k
          '結果表示
          Call ShowResult
        End If
        '前の交差点に戻るので,通過可能に戻す
        availPoint(nextPt) = True
      End If
    End If
  Next branch
End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchReturnRepeat(curPt As Integer, distance As Integer, move As Integer)
  Dim branch As Integer '分岐
  Dim nextPt As Integer '次交差点
  Dim k    As Integer

  For branch = 1 To nPoint - 1
    '次交差点番号
    nextPt = (curPt + branch - 1) Mod nPoint + 1
    
    '次交差点片道が通過可能の場合
    If availRoad(curPt, nextPt) Then
      '現在の最短距離を越えたら、その先を調べる必要なし。
      If minDistance > distance + dist(curPt, nextPt) Then
        '次交差点への片道を通過するので通過不可能にする
        availRoad(curPt, nextPt) = False
        '次交差点の通行回数を増加する
        checkPoint(nextPt) = checkPoint(nextPt) + 1
        'ルートの履歴設定
        route(move + 1) = nextPt
        'まだ全交差点を回っていない
        If Not CheckAllPoint(move) Then
          '次交差点が出発点でない(全交差点未周回で出発点にもどると打ち切り)
          If nextPt <> startPt Then
            '経路を延ばす。
            Call SearchReturnRepeat(nextPt, distance + dist(curPt, nextPt), move + 1)
          End If
        '全交差点を回っている場合,出発点を加える
        Else
          '現在の最短距離を越えたら、その先を調べる必要なし。
          If minDistance > distance + dist(curPt, nextPt) + dist(nextPt, startPt) Then
            '最短記録更新。
            route(move + 2) = startPt 'ルートの最後に出発点設定
            minDistance = distance + dist(curPt, nextPt) + dist(nextPt, startPt)
            minMove = move + 2
            For k = 1 To minMove
              minRoute(k) = route(k)
            Next k
            '結果表示
            Call ShowResult
          End If
        End If
        '前の交差点に戻るので,通過可能に戻す
        availRoad(curPt, nextPt) = True
        '前の交差点に戻るので,通過回数を戻す
        checkPoint(nextPt) = checkPoint(nextPt) - 1
      End If
    End If
  Next branch
End Sub

'全交差点を通過したかどうか。
Private Function CheckAllPoint(move As Integer)
  Dim i As Integer
  Dim pass As Integer '通過交差点数

  CheckAllPoint = False
   '交差点の通過数が全交差点数以下なら絶対無理
  If move + 1 < nPoint Then Exit Function

  pass = 0
  For i = 1 To nPoint
    '通過済み交差点のカウント
    If checkPoint(i) > 0 Then pass = pass + 1
  Next i
  
  '通過済み交差点数が全交差点数と等しい
  CheckAllPoint = (pass = nPoint)
End Function

'道のデータを読み取る。
Private Sub GetStartPoint(startStt As Integer, StartEnd As Integer)
  Dim stt As Integer '指定出発点番号
  
  stt = Range("start")
  If stt = 0 Then
    startStt = 1
    StartEnd = nPoint
  Else
    startStt = stt
    StartEnd = stt
  End If
End Sub

'道のデータを読み取る。
Private Sub GetRoadTable()
  Dim i As Integer
  Dim j As Integer
  
  nPoint = Range("points").Value
  With Range("road")
    For i = 1 To nPoint
      For j = 1 To nPoint
      dist(i, j) = .Cells(i, j).Value
      Next j
    Next i
  End With
End Sub

'通行可能交差点初期設定
Private Sub ClearAvailablePoint()
  Dim i As Integer
  
  For i = 1 To nPoint
    availPoint(i) = True
  Next i
End Sub

'通行可能片道初期設定 & 通過交差点初期設定
Private Sub ClearAvailableRoad()
  Dim i As Integer
  Dim j As Integer

  For i = 1 To nPoint
    checkPoint(i) = False '最初は全交差点未通過
    For j = 1 To nPoint
      availRoad(i, j) = dist(i, j) > 0 '片道に距離が設定されていたらTrue
    Next j
  Next i
End Sub

'結果を削除
Private Sub ClearResult()
  Dim k As Integer

  Range("minDistance").Clear
  With Range("route")
    For k = 1 To 20
      .Cells(k, 1).Clear
    Next k
  End With
End Sub

'結果を表示
Private Sub ShowResult()
  Dim k As Integer

  Range("minDistance").Value = minDistance
  With Range("route")
    For k = 1 To minMove
      .Cells(k, 1).Value = minRoute(k)
    Next k
  .Range(Cells(minMove + 1, 1), Cells(minMove * 2, 1)).Value = ""
  End With
End Sub

'メッセージを表示
Private Sub ShowMsg(msg As String)
  Range("message").Value = msg
End Sub
    • good
    • 0

>プログラムを組んでもらいました。


ということは、
スタートが交差点xで、ゴールが交差点1のとき
から
>スタートが交差点xで、ゴールが交差点14のとき
まで、出てくるのがあるっていう風に読み取れるのですが、違いますか?

もしそうなら、スタート、ゴールを入力させて、合致する答えのみ表示させればいいのではないですか?

素人の人が、計算の部分を触らずに、入出力だけ細工して済むなら、最良の解決法です。(企業においては・・)
    • good
    • 0
この回答へのお礼

ご回答、ありがとうございます。
組んでもらったプログラムは、入力する部分はスタートのみだったものです。

以下が、組んでもらったプログラムです。
このうち、一筆経路探索の方です。

Option Explicit

Public nPoint As Integer '交差点の数
Public dist(20, 20) As Integer '距離を入れておくテーブル
Public availRoad(20, 20) As Boolean '片道通過可能テーブル 既に通ったかどうかを記録
Public availPoint(20) As Boolean '交差点通過可能配列 交差点を既に通ったかどうかを記録
Public checkPoint(20) As Integer '交差点通過回数配列
Public move As Integer '現在作りかけの経路の通過する交差点の延べ数
Public route(50) As Integer '現在作りかけの経路
Public distance As Integer '現在作りかけの経路の距離
Public minRoute(50) As Integer 'これまでに見つかった最短経路
Public minMove As Integer 'これまでに見つかった最短経路の通過する交差点の延べ数
Public minDistance As Integer 'これまでに見つかった最短経路の距離
Public startPt As Integer '出発交差点

'一筆経路探索(一度通過した交差点は通らない)
Sub SearchMove()
Dim startStt As Integer '出発点の開始交差点番号
Dim StartEnd As Integer '出発点の終了交差点番号


ShowMsg "一筆探索 実行中" 'メッセージ表示

ClearResult '結果削除

GetRoadTable '道のデータを読み取る。

ClearAvailablePoint '通行可能交差点初期設定

'検索
GetStartPoint startStt, StartEnd '出発点の範囲取得
minDistance = 30000 '大きな数値を入れておく

For startPt = startStt To StartEnd
ShowMsg "一筆探索 実行中 出発点" + str(startPt)
availPoint(startPt) = False '出発点通過するので通過不可能にする
route(1) = startPt 'ルートの履歴設定
SearchMoveRepeat startPt, 0, 1 '出発点startPtから経路検索
availPoint(startPt) = True '通過可能に戻す
Next
'結果表示
ShowResult

'メッセージ表示
ShowMsg "一筆探索 終了"

End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
Sub SearchReturn()
Dim startStt As Integer '出発点の開始交差点番号
Dim StartEnd As Integer '出発点の終了交差点番号


ShowMsg "一巡探索 実行中" 'メッセージ表示

ClearResult '結果削除

GetRoadTable '道のデータを読み取る。

ClearAvailableRoad '通行可能片道初期設定 & 通過交差点初期設定

'検索
GetStartPoint startStt, StartEnd '出発点の範囲取得
minDistance = 30000 '大きな数値を入れておく
For startPt = startStt To StartEnd
ShowMsg "一巡探索 実行中 出発点" + str(startPt)
route(1) = startPt 'ルートの履歴設定
checkPoint(startPt) = 1 '出発点1回通過済み
SearchReturnRepeat startPt, 0, 1 '出発点startPtから経路検索
checkPoint(startPt) = 0 '出発点を未通過に戻す
Next
'結果表示
ShowResult

'メッセージ表示
ShowMsg "一巡探索 終了"

End Sub


'一筆経路探索(一度通過した交差点は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchMoveRepeat(curPt As Integer, distance As Integer, move As Integer)
Dim branch As Integer '分岐
Dim nextPt As Integer '次交差点
Dim k As Integer

For branch = 1 To nPoint - 1
nextPt = (curPt + branch - 1) Mod nPoint + 1 '次交差点番号
If availPoint(nextPt) Then '次交差点通過可能の場合
If minDistance > distance + dist(curPt, nextPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
availPoint(nextPt) = False '次交差点を通過するので通過不可能にする
route(move + 1) = nextPt 'ルートの履歴設定
If move + 1 < nPoint Then 'まだ全交差点を回っていない
SearchMoveRepeat nextPt, distance + dist(curPt, nextPt), move + 1 '経路を延ばす。
Else '全交差点を回っている場合最短記録更新。
minDistance = distance + dist(curPt, nextPt) '全距離
minMove = move + 1 '全交差点数
For k = 1 To minMove '全ルート履歴
minRoute(k) = route(k)
Next
ShowResult '結果表示
End If
availPoint(nextPt) = True '前の交差点に戻るので,通過可能に戻す
End If
End If
Next
End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchReturnRepeat(curPt As Integer, distance As Integer, move As Integer)
Dim branch As Integer '分岐
Dim nextPt As Integer '次交差点
Dim k As Integer

For branch = 1 To nPoint - 1
nextPt = (curPt + branch - 1) Mod nPoint + 1 '次交差点番号
If availRoad(curPt, nextPt) Then '次交差点片道が通過可能の場合
If minDistance > distance + dist(curPt, nextPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
availRoad(curPt, nextPt) = False '次交差点への片道を通過するので通過不可能にする
checkPoint(nextPt) = checkPoint(nextPt) + 1 '次交差点の通行回数を増加する
route(move + 1) = nextPt 'ルートの履歴設定
If Not CheckAllPoint(move) Then 'まだ全交差点を回っていない
If nextPt <> startPt Then '次交差点が出発点でない(全交差点未周回で出発点にもどると打ち切り)
SearchReturnRepeat nextPt, distance + dist(curPt, nextPt), move + 1 '経路を延ばす。
End If
Else '全交差点を回っている場合,出発点を加える
If minDistance > distance + dist(curPt, nextPt) + dist(nextPt, startPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
'最短記録更新。
route(move + 2) = startPt 'ルートの最後に出発点設定
minDistance = distance + dist(curPt, nextPt) + dist(nextPt, startPt)
minMove = move + 2
For k = 1 To minMove
minRoute(k) = route(k)
Next
ShowResult '結果表示
End If
End If
availRoad(curPt, nextPt) = True '前の交差点に戻るので,通過可能に戻す
checkPoint(nextPt) = checkPoint(nextPt) - 1 '前の交差点に戻るので,通過回数を戻す
End If
End If
Next
End Sub

'全交差点を通過したかどうか。
Private Function CheckAllPoint(move As Integer)
Dim i As Integer
Dim pass As Integer '通過交差点数

CheckAllPoint = False
If move + 1 < nPoint Then Exit Function '交差点の通過数が全交差点数以下なら絶対無理

pass = 0
For i = 1 To nPoint
If checkPoint(i) > 0 Then pass = pass + 1 '通過済み交差点のカウント
Next

CheckAllPoint = (pass = nPoint) '通過済み交差点数が全交差点数と等しい
End Function

'道のデータを読み取る。
Private Sub GetStartPoint(startStt As Integer, StartEnd As Integer)
Dim stt As Integer '指定出発点番号

stt = Range("start")
If stt = 0 Then
startStt = 1
StartEnd = nPoint
Else
startStt = stt
StartEnd = stt
End If
End Sub

'道のデータを読み取る。
Private Sub GetRoadTable()
Dim i As Integer
Dim j As Integer

nPoint = Range("points").Value
With Range("road")
For i = 1 To nPoint
For j = 1 To nPoint
dist(i, j) = .Cells(i, j).Value
Next
Next
End With
End Sub

'通行可能交差点初期設定
Private Sub ClearAvailablePoint()
Dim i As Integer

For i = 1 To nPoint
availPoint(i) = True
Next
End Sub

'通行可能片道初期設定 & 通過交差点初期設定
Private Sub ClearAvailableRoad()
Dim i As Integer
Dim j As Integer

For i = 1 To nPoint
checkPoint(i) = False '最初は全交差点未通過
For j = 1 To nPoint
availRoad(i, j) = dist(i, j) > 0 '片道に距離が設定されていたらTrue
Next
Next
End Sub

'結果を削除
Private Sub ClearResult()
Dim k As Integer

Range("minDistance").Clear
With Range("route")
For k = 1 To 20
.Cells(k, 1).Clear
Next k
End With
End Sub

'結果を表示
Private Sub ShowResult()
Dim k As Integer

Range("minDistance").Value = minDistance
With Range("route")
For k = 1 To minMove
.Cells(k, 1).Value = minRoute(k)
Next k
.Range(Cells(minMove + 1, 1), Cells(minMove * 2, 1)).Value = ""
End With
End Sub

'メッセージを表示
Private Sub ShowMsg(msg As String)
Range("message").Value = msg
End Sub

お礼日時:2001/11/21 12:54

見てみたいですー

    • good
    • 0
この回答へのお礼

ありがとうございます。
見ていただけますか?

以下が組んでもらったプログラムで「一筆経路探索」の方です。

Option Explicit

Public nPoint As Integer '交差点の数
Public dist(20, 20) As Integer '距離を入れておくテーブル
Public availRoad(20, 20) As Boolean '片道通過可能テーブル 既に通ったかどうかを記録
Public availPoint(20) As Boolean '交差点通過可能配列 交差点を既に通ったかどうかを記録
Public checkPoint(20) As Integer '交差点通過回数配列
Public move As Integer '現在作りかけの経路の通過する交差点の延べ数
Public route(50) As Integer '現在作りかけの経路
Public distance As Integer '現在作りかけの経路の距離
Public minRoute(50) As Integer 'これまでに見つかった最短経路
Public minMove As Integer 'これまでに見つかった最短経路の通過する交差点の延べ数
Public minDistance As Integer 'これまでに見つかった最短経路の距離
Public startPt As Integer '出発交差点

'一筆経路探索(一度通過した交差点は通らない)
Sub SearchMove()
Dim startStt As Integer '出発点の開始交差点番号
Dim StartEnd As Integer '出発点の終了交差点番号


ShowMsg "一筆探索 実行中" 'メッセージ表示

ClearResult '結果削除

GetRoadTable '道のデータを読み取る。

ClearAvailablePoint '通行可能交差点初期設定

'検索
GetStartPoint startStt, StartEnd '出発点の範囲取得
minDistance = 30000 '大きな数値を入れておく

For startPt = startStt To StartEnd
ShowMsg "一筆探索 実行中 出発点" + str(startPt)
availPoint(startPt) = False '出発点通過するので通過不可能にする
route(1) = startPt 'ルートの履歴設定
SearchMoveRepeat startPt, 0, 1 '出発点startPtから経路検索
availPoint(startPt) = True '通過可能に戻す
Next
'結果表示
ShowResult

'メッセージ表示
ShowMsg "一筆探索 終了"

End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
Sub SearchReturn()
Dim startStt As Integer '出発点の開始交差点番号
Dim StartEnd As Integer '出発点の終了交差点番号


ShowMsg "一巡探索 実行中" 'メッセージ表示

ClearResult '結果削除

GetRoadTable '道のデータを読み取る。

ClearAvailableRoad '通行可能片道初期設定 & 通過交差点初期設定

'検索
GetStartPoint startStt, StartEnd '出発点の範囲取得
minDistance = 30000 '大きな数値を入れておく
For startPt = startStt To StartEnd
ShowMsg "一巡探索 実行中 出発点" + str(startPt)
route(1) = startPt 'ルートの履歴設定
checkPoint(startPt) = 1 '出発点1回通過済み
SearchReturnRepeat startPt, 0, 1 '出発点startPtから経路検索
checkPoint(startPt) = 0 '出発点を未通過に戻す
Next
'結果表示
ShowResult

'メッセージ表示
ShowMsg "一巡探索 終了"

End Sub


'一筆経路探索(一度通過した交差点は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchMoveRepeat(curPt As Integer, distance As Integer, move As Integer)
Dim branch As Integer '分岐
Dim nextPt As Integer '次交差点
Dim k As Integer

For branch = 1 To nPoint - 1
nextPt = (curPt + branch - 1) Mod nPoint + 1 '次交差点番号
If availPoint(nextPt) Then '次交差点通過可能の場合
If minDistance > distance + dist(curPt, nextPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
availPoint(nextPt) = False '次交差点を通過するので通過不可能にする
route(move + 1) = nextPt 'ルートの履歴設定
If move + 1 < nPoint Then 'まだ全交差点を回っていない
SearchMoveRepeat nextPt, distance + dist(curPt, nextPt), move + 1 '経路を延ばす。
Else '全交差点を回っている場合最短記録更新。
minDistance = distance + dist(curPt, nextPt) '全距離
minMove = move + 1 '全交差点数
For k = 1 To minMove '全ルート履歴
minRoute(k) = route(k)
Next
ShowResult '結果表示
End If
availPoint(nextPt) = True '前の交差点に戻るので,通過可能に戻す
End If
End If
Next
End Sub

'一巡経路探索(出発点へ戻る。一度通過した方向の道は通らない)
'現在交差点curPtに居て、作りかけの経路の距離はdistance、既に交差点move個を通過した。
Private Sub SearchReturnRepeat(curPt As Integer, distance As Integer, move As Integer)
Dim branch As Integer '分岐
Dim nextPt As Integer '次交差点
Dim k As Integer

For branch = 1 To nPoint - 1
nextPt = (curPt + branch - 1) Mod nPoint + 1 '次交差点番号
If availRoad(curPt, nextPt) Then '次交差点片道が通過可能の場合
If minDistance > distance + dist(curPt, nextPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
availRoad(curPt, nextPt) = False '次交差点への片道を通過するので通過不可能にする
checkPoint(nextPt) = checkPoint(nextPt) + 1 '次交差点の通行回数を増加する
route(move + 1) = nextPt 'ルートの履歴設定
If Not CheckAllPoint(move) Then 'まだ全交差点を回っていない
If nextPt <> startPt Then '次交差点が出発点でない(全交差点未周回で出発点にもどると打ち切り)
SearchReturnRepeat nextPt, distance + dist(curPt, nextPt), move + 1 '経路を延ばす。
End If
Else '全交差点を回っている場合,出発点を加える
If minDistance > distance + dist(curPt, nextPt) + dist(nextPt, startPt) Then '現在の最短距離を越えたら、その先を調べる必要なし。
'最短記録更新。
route(move + 2) = startPt 'ルートの最後に出発点設定
minDistance = distance + dist(curPt, nextPt) + dist(nextPt, startPt)
minMove = move + 2
For k = 1 To minMove
minRoute(k) = route(k)
Next
ShowResult '結果表示
End If
End If
availRoad(curPt, nextPt) = True '前の交差点に戻るので,通過可能に戻す
checkPoint(nextPt) = checkPoint(nextPt) - 1 '前の交差点に戻るので,通過回数を戻す
End If
End If
Next
End Sub

'全交差点を通過したかどうか。
Private Function CheckAllPoint(move As Integer)
Dim i As Integer
Dim pass As Integer '通過交差点数

CheckAllPoint = False
If move + 1 < nPoint Then Exit Function '交差点の通過数が全交差点数以下なら絶対無理

pass = 0
For i = 1 To nPoint
If checkPoint(i) > 0 Then pass = pass + 1 '通過済み交差点のカウント
Next

CheckAllPoint = (pass = nPoint) '通過済み交差点数が全交差点数と等しい
End Function

'道のデータを読み取る。
Private Sub GetStartPoint(startStt As Integer, StartEnd As Integer)
Dim stt As Integer '指定出発点番号

stt = Range("start")
If stt = 0 Then
startStt = 1
StartEnd = nPoint
Else
startStt = stt
StartEnd = stt
End If
End Sub

'道のデータを読み取る。
Private Sub GetRoadTable()
Dim i As Integer
Dim j As Integer

nPoint = Range("points").Value
With Range("road")
For i = 1 To nPoint
For j = 1 To nPoint
dist(i, j) = .Cells(i, j).Value
Next
Next
End With
End Sub

'通行可能交差点初期設定
Private Sub ClearAvailablePoint()
Dim i As Integer

For i = 1 To nPoint
availPoint(i) = True
Next
End Sub

'通行可能片道初期設定 & 通過交差点初期設定
Private Sub ClearAvailableRoad()
Dim i As Integer
Dim j As Integer

For i = 1 To nPoint
checkPoint(i) = False '最初は全交差点未通過
For j = 1 To nPoint
availRoad(i, j) = dist(i, j) > 0 '片道に距離が設定されていたらTrue
Next
Next
End Sub

'結果を削除
Private Sub ClearResult()
Dim k As Integer

Range("minDistance").Clear
With Range("route")
For k = 1 To 20
.Cells(k, 1).Clear
Next k
End With
End Sub

'結果を表示
Private Sub ShowResult()
Dim k As Integer

Range("minDistance").Value = minDistance
With Range("route")
For k = 1 To minMove
.Cells(k, 1).Value = minRoute(k)
Next k
.Range(Cells(minMove + 1, 1), Cells(minMove * 2, 1)).Value = ""
End With
End Sub

'メッセージを表示
Private Sub ShowMsg(msg As String)
Range("message").Value = msg
End Sub

お礼日時:2001/11/21 12:58

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Q地図:バスのルート検索

googleでもyahooでも何でもいいのですが、地図検索でルートを調べたいのですが、電車ではルート検索できるのですが、バスのルート検索できません。

バスのルート検索ができるサイトとそのやり方を教えてください。

回答よろしくお願いします。

Aベストアンサー

直接、乗車バス停から降車バス停の時刻を調べることはできませんが、
私が愛用させていただいた、
『旅に出たくなるページ』内の『旅に出たくなる路線図』さんが昨年の12月31日をもって閉鎖されてしまいました。これが最高だったので残念です。
しかし、リンク集は残されていますので検索してみる価値は十分有ると思います。
http://ryokou.gozaru.jp/index.html

『時刻表はココから』さんには、各バス会社のホームページや、地域によっては、その地域全体を調べられるものも記載されています。
http://homepage2.nifty.com/fuguta/time/i/i-menu.html

『NAVITIME』さんは、全国の各バス停の発車時刻を調べることができますが、掲載されていないバス停が多々有ります。
http://www.navitime.co.jp/bus/

地域別では、
・関東地方 『バスサービスマップ』さん(路線図の検索)
http://www.geocities.jp/busservicemap/
・東海地方 『路線図ドットコム』さん(路線図の検索)
http://www.rosenzu.com/
・九州地方 『九州のバス時刻表』さん(停留所名で九州のほとんどのバスが検索できます)
http://qbus.jp/time/
などがあります。

miya_HN さんがどの地域をお探しかわかりませんが、手間がかかっても良ければ、各都道府県のバス協会等の大まかなバス路線図は存在すると思いますので、そこでバス会社を調べて、そのバス会社のホームページがあればそれを参照してみてはいかがでしょうか。

直接、乗車バス停から降車バス停の時刻を調べることはできませんが、
私が愛用させていただいた、
『旅に出たくなるページ』内の『旅に出たくなる路線図』さんが昨年の12月31日をもって閉鎖されてしまいました。これが最高だったので残念です。
しかし、リンク集は残されていますので検索してみる価値は十分有ると思います。
http://ryokou.gozaru.jp/index.html

『時刻表はココから』さんには、各バス会社のホームページや、地域によっては、その地域全体を調べられるものも記載されています。
http://homepage2...続きを読む

Qエクセルの入力データーを別のシートの日付と氏名の交差点に記録していくマクロ

現在別のカテゴリーで教えていただいたマクロなのですが、
Sheet1に入力されたデータをSheet2に転記するマクロに苦しんでおります。週明けには解決したいのでこのカテゴリーにも質問することにしました。
現在の状況は以下の通りです。

Sheet1
   A   B   C   D  
1 日付 氏名 成績 区分
2 9/23 佐藤 95  優

ここでマクロを実行すると

Sheet2
   A   B   C   D   E   F  G
1       1組       2組
2    田中 佐藤 小林 近藤 三浦 遠藤
3 9/19 90 
4 9/21         80
5 9/21    95
6 9/21            95
7 9/22                 95

となって欲しいのですが、同じ日付で続けて入力すると

Sheet2
   A   B   C   D   E   F  G
1       1組       2組
2    田中 佐藤 小林 近藤 三浦 遠藤
3 9/19 90 
4 9/21    95   80  95
5 9/21    
6 9/21            
7 9/22                 95

となってしまいます。
マクロは

Sub Macro001()
'まず日付を転記します
 Range("A2").Select
 Selection.Copy
 Sheets("sheet2").Select
 Range("A65536").Select
 Selection.End(xlUp).Select
 ActiveCell.Offset(1, 0).Select
 Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
 False, Transpose:=False
 Sheets("sheet1").Select
 Application.CutCopyMode = False
 Range("C3").Select

'続いて転記します
 Dim x As Long
 Dim y As Integer

 x = Application.Match(Sheets("sheet1").Range("a2"), Sheets("sheet2").Columns(1), 0)
 y = Application.Match(Sheets("sheet1").Range("b2"), Sheets("sheet2").Rows(2), 0)
 Sheets("sheet2").Cells(x, y) = Sheets("sheet1").Range("C2")

End Sub

です。
どうかよろしくお願いいたします。

現在別のカテゴリーで教えていただいたマクロなのですが、
Sheet1に入力されたデータをSheet2に転記するマクロに苦しんでおります。週明けには解決したいのでこのカテゴリーにも質問することにしました。
現在の状況は以下の通りです。

Sheet1
   A   B   C   D  
1 日付 氏名 成績 区分
2 9/23 佐藤 95  優

ここでマクロを実行すると

Sheet2
   A   B   C   D   E   F  G
1       1組       2組
2    田中 佐藤 小林 近...続きを読む

Aベストアンサー

http://okwave.jp/qa4344600.html
補足入っていたんですね。

Sub test()
Dim r As Range
Dim col As Long

With Worksheets("Sheet2")
Set r = .Range("A" & Rows.Count).End(xlUp).Offset(1)
If r.Row < 3 Then Set r = .Range("A3")

col = Application.Match(Worksheets("Sheet1").Range("B2").Value, _
.Range(.Range("B2"), .Cells(2, Columns.Count).End(xlToLeft)), 0)

Worksheets("Sheet1").Range("A2").Copy r
r.Offset(, col).Value = Worksheets("Sheet1").Range("C2").Value
End With
Set r = Nothing
End Sub
ご参考になれば。(名前がない時のエラー処理はしてませんけど)

http://okwave.jp/qa4344600.html
補足入っていたんですね。

Sub test()
Dim r As Range
Dim col As Long

With Worksheets("Sheet2")
Set r = .Range("A" & Rows.Count).End(xlUp).Offset(1)
If r.Row < 3 Then Set r = .Range("A3")

col = Application.Match(Worksheets("Sheet1").Range("B2").Value, _
.Range(.Range("B2"), .Cells(2, Columns.Count).End(xlToLeft)), 0)

Worksheets("Sheet1").Range("A2").Copy r
r.Offset(, col).Value = Worksheets("Sheet1").Range("C2").Value
End Wi...続きを読む

Q■地図ナビルート検索について!

■地図ナビルート検索について!
自宅のパソコンでルート検索できるソフトやサイトはありますか?
出来れば無料の物が良いのですが・・・? 有料でもOKです。

目的地と到着地を設定してルート検索ができるようなものを教えてください。
その他関連するご回答があればお願いいたします。m(_ _)m

Aベストアンサー

自動車であれば、
ルート検索‐NAVITIME
http://www.navitime.co.jp/drive/

電車であれば、
まるごとナビ|駅探
http://navi.ekitan.com/ppnavi/

などいかがですか。

Qスタートメニュー → 全てのプログラム → で表示されるアイコンが全て末がlnkに変わってしまい開け

スタートメニュー → 全てのプログラム → で表示されるアイコンが全て末がlnkに変わってしまい開けません。
例えば、アクセサリーのペイントを使いたくてクリックするとメモが出てくる状況です。そのメモには、バグの文字が記載されている状態です。

スタートをクリックしてみるとここに出ているファイルの後ろに.lnkという拡張子が付いていました。
おそらく何らかの理由でリンク付けされてしまっていたようです。

コントロールパネルの既定のプログラムの関連付けを設定するのところを見るとlnkの現在の設定がメモになっています。自分で謝ってlnkの関連付けをもともとの不明なアプリケーションから、メモに設定を変えてしまった為です。

lnkを使えるように直す方法はありますか?

困っております。
大至急、宜しくお願い致します。

Aベストアンサー

以下の状態でしょうか?
http://dynabook.com/assistpc/faq/pcdata/013374.htm
http://wintips.blog117.fc2.com/blog-entry-16.html

であれば、レジストリ エディターを開き
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\.lnk\UserChoice
キーを削除してください。

Qgoogle mapでのルート検索を良く利用していますが、一つ困ってい

google mapでのルート検索を良く利用していますが、一つ困っている事があります。

google mapが検索したルートを少しアレンジするのに白丸○で表されたポイントを
ドラッグすれば良いのですが、うまくドラッグ出来た試しがありません。

付近をぐるぐる何度も周回するようなルート地図が出来上がってしまいます。

何か途中のルートポイントを削除する方法などはあるのでしょうか?
みなさんはどのようにしてらっしゃいますか?

Aベストアンサー

補足確認しました。

(^^ゞ失礼しました言葉足らずでした。

不要なルート表示に○が有る時は○にカーソルを合わせて右クリックで、「このポイントを削除」で消せると思います。

無い場合は不要なルートを利用したいルートへドラッグで消えると思います。

>ちょっとごちゃごちゃした右左折の多いルート時なのか、時々ポイントをドラッグするとぐるぐる同じところを周回するんです。

ご指摘の様に表示してるルートと利用したいルートが近い場合はぐるぐると回る様な表示になりますね!

その様な場合は地図を拡大してルートを設定(上記の方法)を試して見て下さい、これは仕様だと思うので根気良く不要なポイント等を削除し続けて我慢するしか無いと思いますよ~?

Qスタートの全てのプログラムでVBとc++が少し違う

・Microsoft Visual Basic 2008 Express Edition
・Microsoft Visual C++ 2008 Express Edition
の2つをインストールしました。

しかしスタートの全てのプログラムを見ると
C++ の方はフォルダにはいっていて、
VBの方はそのまま(裸のまま)プログラム一覧に表示されています。

Visual C++ の方はフォルダの中身は
・Microsoft Visual C++ 2008 Express Editionのアプリケーションと
・Visual Studio Toolsフォルダです。

Visual Studio Toolsの中には
Visual Studio 2008 コマンド プロンプト
が入っています。

これは標準の配置ですか?
もしかしたら私が知らぬ間にいじったのか気になります。
OSはvistaです。
よろしくお願いします。

Aベストアンサー

正しいと思います。
Visual Basic 2008 Express Edition は本体の開発ツールのほか、MSDN Express ライブラリだけなので。
http://www.microsoft.com/japan/msdn/vstudio/2008/product/express/online.aspx

Q途中を指定できるルート検索サイト

ルートMAPを使っていますが、途中ポイントを指定して使用できません。
どこか途中ポイントを1-2点指定して検索できるサイトがあれば紹介お願いします。
→全て途中ポイントを目的地にして検索し足せばよいのはわかっていますが、あっちこっちポイントを変えたいので、、
使い方
  (1)目的地と出発地は決まっているのですが、途中観光する場所が3-4個所あるのでその組み合わせをそれぞれ指定して検索したい。
(2)検索条件を入れて検索しているが、部分的に自分の知っている最短ルートになっていない。そこでルートを指定して検索したい(私の方が絶対近いと思っているが、、、?)などなど

Aベストアンサー

 参考にならない意見ですいませんが、中継点を指定できるウェブ検索は、今のところまだないと思います。
(将来的には近いうちにどっかが始めると思いますが、2006年5月現在ではまだ見ないです)

 現在ルート検索で使われている処理方式は「可能性のある全てのルートを検索し、その中から最適なものを選ぶ」という処理方式が取られていることが多いです。
 そのようなアルゴリズムである関係上、「ウェブにルート検索を載せた」こと自体、実は凄いことなんです。

 中継点付きルート検索の場合、中継点の数だけ同じ検索を繰り返すため処理が2倍3倍と増えていく関係上、かなり潤沢な資金のある会社でなければ、それほどの能力を持ったシステムは導入できないのが実情です。
 地図検索サイトを運営する多くの会社にとって、ルート検索は一般に「おまけ機能」であることが多く、資金を裂けないわけです。

(カーナビに搭載された検索システムは、あなたが個人的に使うからこそ中継点指定ができるんです。
 ウェブ検索では何人もの人間が同時に使うのですから、みんなでサーバーの処理能力を譲り合わなければいけません。「みんなで分け合ってもなお余裕のあるシステム」となると、それなりに処理能力が求められるっちゅーわけです)

 参考にならない意見ですいませんが、中継点を指定できるウェブ検索は、今のところまだないと思います。
(将来的には近いうちにどっかが始めると思いますが、2006年5月現在ではまだ見ないです)

 現在ルート検索で使われている処理方式は「可能性のある全てのルートを検索し、その中から最適なものを選ぶ」という処理方式が取られていることが多いです。
 そのようなアルゴリズムである関係上、「ウェブにルート検索を載せた」こと自体、実は凄いことなんです。

 中継点付きルート検索の場合、...続きを読む

QVS2003で「プログラムから開く」のプログラム名称

いつもお世話になっております。
現在、VS2003にてVisual Basicでプログラムを開発しております。
開発したexeは、起動時のパラメータ(画像ファイルパス)により動きを分岐しております。
プログラム自体は正常に動いているのですが、プログラム名称が反映されていません。
具体的には、

・開発したプログラムはSetupにてインストールします。
・エクスプローラで画像ファイルを選択して右クリックします。
・「プログラムから開く」-「プログラムの選択」
・参照ボタンでインストールしたプログラムのexeを選択

ですが、一覧にアイコンは表示されるのですが、プログラム名称が空白です。
この名称のデータはどこで指定するのでしょうか?
VS2005では、何も苦労する事なく表示されたような気がしますが、VS2003だと表示されません。
ご教授のほど、よろしくお願いいたします。
XP Pro SP2/VS2003/VB/.NET Freamwork 1.1

Aベストアンサー

AssemblyInfo.vb に
<Assembly: AssemblyTitle("")>
という記述があると思います。これを
<Assembly: AssemblyTitle("XXXX")>
のようにすると、アプリケーションのタイトルが XXXX になります。
ただし、一度、"" の状態で「ファイルを開くプログラムの選択」で選択すると、レジストリの
HKEY_CURRENT_USER\Software\Microsoft\Windows\ShellNoRoam\MUICache
に記録されてしまうみたいです。いったんこれを削除して、再度、「ファイルを開くプログラムの選択」で選択するとタイトルが表示されると思います。

Q・カーナビのようにルート検索ができるサイト

・カーナビのようにルート検索ができるサイト

自宅のパソコンで出発地と目的地を入力してルート検索、距離、所要時間などがわかるカーナビのようなサイトを探しているのですが知っている方いませんでしょうか?
よろしくお願いします。

Aベストアンサー

マップファンを使っています。

http://www.mapfan.com/

『ルート検索』で多分ご希望どうりのものが出来ると思います。
ラリーマップは便利で楽しいですよ(笑)

Q【VB2005】別のプログラムから別のプログラム起動

"A"というVB2005で、作成したプログラムがありまして、
メインのフォームがあり、
そこにボタンがあります。
Shellの関数を使って、クリックイベントで、
指定したExe"B"を立ち上げます。

そのExe"B"は、VB2005で作成したオリジナルのプログラムです。
プロジェクトは別で作った物と考えてください。

Exe"B"を起動した画面を[フォーム1]と考えて、
ボタンがあり、クリックすると
別の[フォーム2]が表示するはずなのですが、
特にエラーも掴まずに、Showで開くことができません。

しかし、Exe"B"からダイレクトに起動させて
ボタンをクリックしたら[フォーム2]が表示されます。

どうしたら、Exe"A"からExe"B"を起動して
Exe"B"からフォーム2を呼び出すことができるか、
考えられる要因などをアドヴァイスして頂けたら助かります。

Aベストアンサー

意味がよくわかりませんので、補足をお願いします。

A.EXE と B.EXE という実行ファイルがあり、それらは VB 2005 で
作ったもので……
A.EXE から Shell 関数で B.EXE を起動すると B.EXE が持っている
Form2 の表示が不可能となるが
A.EXE を起動していない状態で B.EXE を起動すると B.EXE が
持っている Form2 の表示が可能である。

という意味なのでしょうか?

A.EXE から B.EXE の起動と表示を行う箇所のコードも記述して
頂けると何かわかるかも知れません。


人気Q&Aランキング