| |
▼うしろ さん：
>以下に示すような系統図があり、それぞれ路線（root＊）は延長、面積を持っています。
>
>rootA--rootB-+rootD-+rootH-+rootK(out)
> | | |
> rootC-+ | |
>rootE--rootF--rootG-+ |
> |
> rootI--rootJ-+
>＜したいこと＞
>起点路線から延長、面積を合計し、延長は合流点で上流側の長い延長に自分の延長を加えるようにする。
>
まだ途中ですが、
計算順を調べるには「トポロジカル・ソート」とか
トポロジカル・ソーティング をキーワードにして検索してみてください。
[A:D]に元データが以下のようにあったとして
[F: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
|
|
kanabun
- 12/11/15(木) 12:57 -
