Excel VBA質問箱 IV

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

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


1611 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【73109】どのように考え方を整理すれば良いでしょ...
質問  うしろ  - 12/11/14(水) 21:50 -

引用なし
パスワード
   以下に示すような系統図があり、それぞれ路線(root*)は延長、面積を持っています。

rootA--rootB-+rootD-+rootH-+rootK(out)
       |   |   |
    rootC-+   |   |
rootE--rootF--rootG-+   |
              |
       rootI--rootJ-+
データは、以下のように整理しました。
路線名 接続先 延長 面積
rootA  rootB  120  10
rootB  rootD  50  20
rootD  rootH  110  50
rootH  rootK  30  30
rootC  rootD  60  20
rootE  rootF  100  40
rootF  rootG  90  70
rootG  rootH  70 100
rootI  rootJ  80  80
rootJ  rootK  20  60
rootK      10  70
<これまで行ったこと>
これらの路線名、接続先を読み込み接続先のループ内に路線名のループを回し
全データ比較してヒットしなかった場合、起点路線であることまでは検出できました。路線名(Rname),接続先(Oneme)、起点路線(Rst)とすると以下のコードで
起点路線まで見つけることができました。
for i= i to Ndat
  for j= i to Ndat
    if(Oname(i)=Rname(j))then
      exit for
    elseif(j=Ndat)then
      icnt=icnt+1
      Rstr(icnt)=Rname(i)
    endif
  next j
next i
<したいこと>
起点路線から延長、面積を合計し、延長は合流点で上流側の長い延長に自分の延長を加えるようにする。

<質問>
接続先のループを回して同じものを集計すれば面積は計算できそうですが、先に起点から合流点まの階層数を調べなければ合計ができそうもないので行き詰まってしまいました。
どなたか、よい考え方があればご教授願います。

<結果の例>
路線名 延長 面積
rootA  120  1
rootB  170  3

rootC   60  2
rootD  280 10

rootE  100  4
rootF  190 11
rootG  260 21
rootH  310 34

rootI   80  8
rootJ  100 14
rootK  320 55

【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

【73114】Re:どのように考え方を整理すれば良いで...
発言  kanabun  - 12/11/15(木) 21:10 -

引用なし
パスワード
   ▼うしろ さん:

(書籍からの引用です)
トポロジカル・ソーティング

n件の仕事がある。同時に2件の仕事を行うことはできない。
仕事i が終わらないと仕事j が始められないならばaij=1,
そうでないならば aij=0 とする。
このaij のデータに基づき、どういう順序で仕事を行えばよいかを
1列に(何通りも可能なばあいは1通りだけ) 書き並べたい。
これがトポロジカル・ソーティングの問題である。
換言すれば、半順序関係が与えられたときの<整列>である。
aij はGraph理論 でいう有向グラフの隣接行列に他ならない。
a12 = a23 = a31 = 1 のようなサイクルがあると解はない。

アルゴリズムは、隣接行列aijの転置(iとjの立場を逆にしたもの)
に基づいて通常の<縦形検索>を行い、点を訪れる手続き
visit() の最後にその点の番号を書き出すだけでよい。
こうすれば、点の番号が書き出された時点では、その点に
行くために訪問しなければならない点はすべて訪問してしまっ
ているからである。
(奥村晴彦『C言語によるアルゴリズム事典』p.198)

【73116】Re:どのように考え方を整理すれば良いで...
発言  kanabun  - 12/11/15(木) 23:00 -

引用なし
パスワード
   ▼うしろ さん:

(改訂版)です
延長と面積のうち、面積のほうは上流の面積をすべて加えたものと
するようにしました。
(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

【73118】Re:どのように考え方を整理すれば良いで...
お礼  うしろ  - 12/11/16(金) 21:05 -

引用なし
パスワード
   ご返答がおそくなりまして・・・
かなり高度な技術をお使いになられていらっしゃるので
大変勉強になります。
少し勉強させていただきます。

【73119】Re:どのように考え方を整理すれば良いで...
お礼  うしろ  - 12/11/16(金) 21:12 -

引用なし
パスワード
   ▼kanabun さん:
いろいろ調べていただきありがとうございました。
仕事をトポロジカルソートすると、ジョブに着手すべき順番がわかる
ということですね。

【73120】Re:どのように考え方を整理すれば良いで...
発言  kanabun  - 12/11/17(土) 9:37 -

引用なし
パスワード
   ▼うしろ さん:

>仕事をトポロジカルソートすると、ジョブに着手すべき順番がわかる
>ということですね。

トポロジカル・ソーティングでググったら
絵入りでこんなのが↓

ht tp://ameblo.jp/mingw/entry-10389158344.html

すでに参考にされていたら失礼。

【73126】Re:どのように考え方を整理すれば良いで...
お礼  うしろ  - 12/11/17(土) 23:33 -

引用なし
パスワード
   ▼kanabun さんへ

>すでに参考にされていたら失礼。

大変参考になりました。
絵で見ると大変分かりやすですね。

【73127】Re:どのように考え方を整理すれば良いで...
お礼  うしろ  - 12/11/18(日) 5:58 -

引用なし
パスワード
   kanabun さん

なんどもご指導ありがとうございました。
そのまま理解できるほど経験がないので、変数にすべてdebug.print
を入れて表に書き出して、変数の変化を確認していたので、ご返答が遅
くなりました。

TopoMainの面積の合計値が異なる部分は、コードを拝見して、
jとwhichの関係を修正すればなんとかなりそうな気がしたのですが…
実際には正解を導き出せまsんでした。

自分なりに調べ、多くの書籍に分木のアルゴリズムの記載がありましたが、
今回のような合流をどう扱うのかが力量不足でできませんでした。

このため、質問箱で相談させていただきました。

個人の勉強となった点は、
>Set dic = CreateObject("Scripting.Dictionary")
>dic(Rname(i))=i

文字列などの変数をそのままID化(この表現で正しいかわかりませんが…)
できる技術は、マトリックスのデータ管理に有効であると感じました。

また、これだけの内容をこれだけのコードで表現できる技術に驚かせ
られました。

私が仮にできたとしても、この10倍以上のコードをゴリゴリ記述しなければ
ならないだろうな、と感じています。

本当は、このままいくつか質問をしたのですが、規約上、1問以上の質問は無い
ようにとのことなので、さらに内容理解深めた上で、再度質問させて頂ければ
と思います。
ありがとうございました。

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