Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9186 / 76732 ←次へ | 前へ→

【73111】Re:どのように考え方を整理すれば良いでしょうか。
発言  kanabun  - 12/11/15(木) 12:57 -

引用なし
パスワード
   ▼うしろ さん:
>以下に示すような系統図があり、それぞれ路線(root*)は延長、面積を持っています。
>
>rootA--rootB-+rootD-+rootH-+rootK(out)
>       |   |   |
>    rootC-+   |   |
>rootE--rootF--rootG-+   |
>              |
>       rootI--rootJ-+


><したいこと>
>起点路線から延長、面積を合計し、延長は合流点で上流側の長い延長に自分の延長を加えるようにする。
>

まだ途中ですが、
計算順を調べるには「トポロジカル・ソート」とか
トポロジカル・ソーティング をキーワードにして検索してみてください。

[A:D]に元データが以下のようにあったとして
[F:H]列に計算結果を表示しています。

A   B   C  D    F  G  H 
路線名 接続先 延長 面積   路線名 総延長 面積
A   B   120  10    A  120   10
B   D    50  20    B  170   30
C   D    60  20    C  60   20
D   H   110  50    D  280   80
E   F   100  40    E  100   40
F   G    90  70    F  190  110
G   H    70  100    G  260  210
H   K    30  30    H  310  110
I   J    80  80    I   80   80
J   K    20  60    J  100  140
K       10  70    K  320  180
(途中まで)というのは 面積が総面積の計算になっていない、という
ことです。ここは修正する必要があります。

'--------------------------- 標準モジュール
Option Explicit
Public Enum VisitFlag
 NEVER = 0
 JUST
 ONCE
End Enum

Private Const N = 11
Private Order&
Private Rname$(1 To N)
Private Oname$(1 To N)
Private mat&(1 To N, 1 To N), Visited&(1 To N)

Private Sub visit(i&)
  Dim j&
  Visited(i) = JUST
  For j = 1 To N
   If mat(j, i) = JUST Then
    If Visited(j) = NEVER Then
      visit j  ' ----------- 再帰して調査
    ElseIf Visited(j) = JUST Then
      MsgBox "サイクルあり", vbCritical
      Stop
    End If
   End If
  Next
  Visited(i) = ONCE
  Order = Order + 1
  Oname(Order) = Rname(i)
End Sub

Sub TopoMain()
  Dim i&, j&, v
  Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
  Dim upper As Object
  Set upper = CreateObject("Scripting.Dictionary")
  
  
  '// データを読む 2行目から
  v = Range("A2").Resize(N, 4).Value
  For i = 1 To N
    Rname(i) = v(i, 1)
    dic(Rname(i)) = i
  Next
  For i = 1 To N
    If Not IsEmpty(v(i, 2)) Then
      j = dic(v(i, 2))
      mat(i, j) = JUST
    End If
  Next
  
  '// ソーティング実行
  For i = 1 To N
    If Visited(i) = NEVER Then visit i
  Next
  '  計算順の表示
  Dim s As String, z As String, e
  ReDim ans(N, 1 To 3)
  ans(0, 1) = "路線名"
  ans(0, 2) = "総延長"
  ans(0, 3) = "面積"
  For i = 1 To N
    s = Oname(i)
    j = dic(s)
    If upper.Exists(v(j, 2)) Then
      upper(v(j, 2)) = upper(v(j, 2)) & "," & Rname(j)
    Else
      upper(v(j, 2)) = Rname(j)
    End If
    Debug.Print Oname(i); "("; upper(Oname(i)); ") ";
    ans(i, 1) = s
    ans(i, 2) = v(j, 3)
    ans(i, 3) = v(j, 4)
  Next
  Debug.Print
  For i = 1 To N
    dic(Oname(i)) = i
  Next

' 上の例ですと
'   A() B(A) C() D(B,C) E() F(E) G(F) H(D,G) I() J(I) K(H,J)
'  のようにイミディエイト・ウィンドウに表示されるはずです。
'  ( ) のなかは 上流路線名です。


  '// 上流から計算
  Dim which As Long
  Dim tot&
  For i = 1 To N
    s = Oname(i)
    '上流を加算
    z = upper(s)
    If Len(z) Then     '上流があるとき
      If InStr(z, ",") > 0 Then '複数上流のとき
        tot = 0
        For Each e In Split(z, ",")
          j = dic(e)
          If tot < ans(j, 2) Then
            tot = ans(j, 2)
            which = j    '総延長の長いほう
          End If
        Next
      Else
        which = dic(upper(s)) '上流番号
      End If
      ans(i, 2) = ans(i, 2) + ans(which, 2)
      ans(i, 3) = ans(i, 3) + ans(which, 3)
     End If
  Next
  Range("F1").Resize(N + 1, 3).Value = ans
  
End Sub

0 hits

【73109】どのように考え方を整理すれば良いでしょうか。 うしろ 12/11/14(水) 21:50 質問
【73111】Re:どのように考え方を整理すれば良いでし... kanabun 12/11/15(木) 12:57 発言
【73118】Re:どのように考え方を整理すれば良いでし... うしろ 12/11/16(金) 21:05 お礼
【73114】Re:どのように考え方を整理すれば良いでし... kanabun 12/11/15(木) 21:10 発言
【73119】Re:どのように考え方を整理すれば良いでし... うしろ 12/11/16(金) 21:12 お礼
【73120】Re:どのように考え方を整理すれば良いでし... kanabun 12/11/17(土) 9:37 発言
【73126】Re:どのように考え方を整理すれば良いでし... うしろ 12/11/17(土) 23:33 お礼
【73116】Re:どのように考え方を整理すれば良いでし... kanabun 12/11/15(木) 23:00 発言
【73127】Re:どのように考え方を整理すれば良いでし... うしろ 12/11/18(日) 5:58 お礼

9186 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free