| |
▼うしろ さん：
(改訂版)です
延長と面積のうち、面積のほうは上流の面積をすべて加えたものと
するようにしました。
（Sub TopoMain に差し替えてください）
Sub TopoMain2()
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
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
'// 上流から計算
Dim z As String, e
Dim which As Long
Dim tot&
For i = 1 To N
dic(Oname(i)) = i '路線名番号を計算順に変更
Next
For i = 1 To N
s = Oname(i)
'上流を加算
z = upper(s)
If Len(z) 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
ans(i, 3) = ans(i, 3) + ans(j, 3) 'すべての上流面積合算
Next
ans(i, 2) = ans(i, 2) + ans(which, 2) '上流延長と合算
End If
Next
Range("F1").Resize(N + 1, 3).Value = ans
End Sub
|
|
kanabun
- 12/11/15(木) 23:00 -
