[[20250108192652]]　『Excel VBAについて（親子関係から組織図を作る）氏x（neko）　ページの最後に飛ぶ

『Excel VBAについて（親子関係から組織図を作る）質問です。』（neko）

Excel VBAについて（親子関係から組織図を作る）質問です。

親子関係にある表から組織図を作成したいと思っています。
A列からD列までのデータをもとにF列以降に出力します。

１　A、B列の所属と同じ行にある親にあたるC、D列をみる
２　C列の値から、A列の値を参照し、該当があれば、その同じ行の親所属を参照する。該当があるまで繰り返す。
　　

 A列　　　　　B列　　　C列　　　　　　D列　
所属コード　所属名　　親所属コード　　親所属名
１　　　　　社長
２　　　　　企画部　　1               　社長
３　　　　　総務部　　2　　　　　　　　企画部
４　　　　　営業　　　2　　　　　　　　企画部
５　　　　　営業１    4                営業

 完成形（同じシートのE列以降に出力）
１　社長
１　社長　2　企画部
１　社長　2　企画部　3　総務部
１　社長　2　企画部　4　営業
１　社長　2　企画部　4　営業　　5　営業１

辞書機能などを使うと出来るかな？と思い、辞書にアイテムを入れるところまで作成したのですが、１、２の動きができません。
もしくは、辞書を使わないでもっと良い方法があるかもと思っているのですが、分かる方いらっしゃいましたら、ご教示お願いします<m(__)m>

※↓は途中まで作成して止まっている状態です。

Sub 所属名作成()
Dim i As Long, j As Long, 範囲 As Variant, i2 As Long
Dim 元 As Worksheet
Dim unit_code As String, unit_name As String
Dim p_unit_code As String, p_unit_name As String

Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")
Dim key As String
Dim item() As Variant

With Worksheets("sheet1")
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
myDic(.Cells(i, 1).Value & .Cells(i, 2).Value) = Array(.Cells(i, 1).Value, _
.Cells(i, 2).Value)
Next i
End With

Set 元 = Sheets("Sheet1")
範囲 = 元.UsedRange.Value

For i2 = 2 To UBound(範囲)
unit_code = 元.Cells(i2, 1)
unit_name = 元.Cells(i2, 2)
p_unit_code = 元.Cells(i2, 3)
p_unit_name = 元.Cells(i2, 4)

key = unit_code & unit_name
If myDic.Exists(key) Then
item = myDic(key)
End If

If item(2) = "" Then
Cells(i2, 7) = item(0)
Cells(i2, 8) = item(1)
Exit For
Else

End If
Next i2

End Sub

＜使用 Excel：Microsoft365、使用 OS：Windows11 ＞

 １回のループではだめかもしれませんが、データ次第。
 Sub test()
    Dim dic As Object
    Dim r As Range
    Dim v
    Dim k As Long
    Dim s1 As String, s2 As String

    Set dic = CreateObject("scripting.dictionary")
    Set r = Cells(1).CurrentRegion.Resize(, 5)
    v = r.Value

    For k = 2 To UBound(v)
        s1 = v(k, 1) & " " & v(k, 2)
        s2 = v(k, 3) & " " & v(k, 4)
        dic(s1) = Trim(dic(s2) & " " & s1)
        v(k, 5) = dic(s1)
    Next
    r.Value = v

    Set r = r.Columns(5)
    r.TextToColumns Destination:=r, DataType:=xlDelimited, _
          Tab:=False, Semicolon:=False, Comma:=False, Space:=True, _
        Other:=False

 End Sub
（マナ） 2025/01/08(水) 20:57:09

教えていただいて、ありがとうございます！！
テストデータで試したところ、意図どおりに動きました。明日、本番データで試して改めてお返事いたします。
取り急ぎお礼まで。。<m(__)m>
（neko） 2025/01/08(水) 21:30:57

 「データ次第」と書いたのは

  親コード＜子コード の関係であることが前提。
 本番データがそうでないなら、期待通りの結果になりません。

　その場合は下記で。（地道に処理を繰り返す以外のアイデアは思いつきませんでした）

 Sub test2()
    Dim dic As Object
    Dim r As Range
    Dim v, v2() As String
    Dim k As Long
    Dim s1 As String, s2 As String, s3 As String

    Set dic = CreateObject("scripting.dictionary")
    ActiveSheet.UsedRange.Offset(, 4).ClearContents
    Set r = Cells(1).CurrentRegion
    v = r.Value
    ReDim v2(1 To r.Rows.Count, 1 To 1)

    For k = 2 To UBound(v)
        s1 = v(k, 1) & " " & v(k, 2)
        s2 = v(k, 3) & " " & v(k, 4)
        Set dic(s1) = CreateObject("system.collections.arraylist")
        If s2 <> " " Then dic(s1).Add s2
        dic(s1).Add s1
    Next

    For k = 2 To UBound(v)
        s1 = v(k, 1) & " " & v(k, 2)
        s2 = v(k, 3) & " " & v(k, 4)
        If s2 <> " " Then
            Do
                s3 = dic(s1)(0)
                If Not dic.exists(s3) Then Exit Do
                If dic(s3).Count = 1 Then Exit Do
                 dic(s1).removeat 0
                 dic(s1).insertrange 0, dic(s3)
            Loop

            If dic(s1).Count - 1 > dic(s2).Count Then
                Set dic(s2) = dic(s1).getrange(0, dic(s1).Count - 1)
            End If
        End If
        v2(k, 1) = Join(dic(s1).toarray, " ")
    Next

    Set r = r.Columns(5)
    r.Value = v2

    r.TextToColumns Destination:=r, DataType:=xlDelimited, _
          Tab:=False, Semicolon:=False, Comma:=False, Space:=True, _
        Other:=False

 End Sub
（マナ） 2025/01/11(土) 20:10:24

マナ様
2回目のお返事に気づくのが遅くなり申し訳ございません。
新たにコードを書いていただいて、ありがとうございました！！こちらのコードも読ませていただき、勉強させていただきます。本当にご親切にありがとうございます。業務に役立てます<m(__)m>
（neko） 2025/01/16(木) 16:55:36

マナ様
1回目のお返事（（neko） 2025/01/08(水) 21:30:57）の後に、本番データでテストしてちゃんと動いたことのお礼をしたつもりだったのですが、返信が反映されていませんでした。。。
遅くなりましたが、１回目のコードのお礼を改めてさせていただきます。２回目のコードも実行して試しました。「system.collections.arraylist」こちらの機能については初めて知りました！いろいろ重ねてありがとうございました！
（neko） 2025/01/16(木) 19:22:45

 横から失礼します。つかぬことをお聞きします。
 結果として得られるものは、組織図の材料にはなるものの、
 一般的な組織図（という図そのもの）ではないですよね。
 その後、どのように図を作成されるのか、参考までに教えていただけますか?

（xyz） 2025/01/17(金) 08:33:59

 既に解決済みですけど、私も作っていたので参考出品しておきます。

 Rem 親子関係からなるtree構造の全パスを取り出す
 Dim dic         As Object   '親組織 => 子組織たち  を保持するdictionary
 Sub main()
     Dim root    As Object
     Dim lastRow&, k&
     Dim s1$, s2$
     Dim r       As Variant
     Dim rng     As Range    '書き込み先のセル範囲
     Dim p&                  '書き込み用配列の行index

     lastRow = Cells(Rows.Count, "A").End(xlUp).Row

     '(1)親子関係を辞書に保持
     Set dic = CreateObject("Scripting.Dictionary")
     ' dic      key: 親組織 , item :  その子組織をカンマで連結した文字列
     For k = 2 To lastRow
         s1 = Cells(k, "A")
         s2 = Cells(k, "B")
         If dic.Exists(s1) Then
             dic(s1) = dic(s1) & "," & s2
         Else
             dic(s1) = s2
         End If
     Next

     '(2)Root(親を持たないnode)を検索
     Set root = CreateObject("Scripting.Dictionary")
     For k = 2 To lastRow
         root(Cells(k, "A").Value) = Empty       '親たちをroot候補として登録
     Next
     For k = 2 To lastRow
         s2 = Cells(k, "B").Value
         If root.Exists(s2) Then root.Remove s2    'それが何かの子になっていれば、それはrootから外す
     Next

     '(3)rootから始まるtreeを走査して、
     '   rootから始まる親子ペアの連結文字列を取得(深さ優先探索を使う再帰処理)
     ReDim v(1 To 1) As String
     For Each r In root
         Call dfs(CStr(r), r, p, v)
     Next

     '(4)結果をシートに書き込み
     Set rng = Range("E2").Resize(p, 1)
     rng.Value = Application.Transpose(v)
     rng.TextToColumns Destination:=rng, DataType:=xlDelimited, _
             Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False
 End Sub

 Function dfs(ss As String, parent As Variant, p As Long, v() As String) 'depth-first search
     Dim child   As Variant
     Dim concatStr As String
     For Each child In Split(dic(parent), ",")
         concatStr = ss & "," & child
         Call setData(p, v, concatStr)       'カンマによる連結文字列を結果配列に書き込み
         Call dfs(concatStr, child, p, v)    '子に対して再帰処理を行う
     Next
 End Function

 '結果書き込みのヘルパー関数
 Function setData(p As Long, v() As String, s As String)
     p = p + 1
     ReDim Preserve v(1 To p)
     v(p) = s
 End Function

   ああ、入力データは↓のようなものを想定していました。（質問のものと若干違います）
   A列     B列
 1 社長    企画部
 2 企画部  総務部
 3 企画部  営業
 4 営業    営業1
 5 社長    企画2部
 6 企画2部 総務2部
 7 企画2部 営業2
 8 営業2   営業3

（xyz） 2025/01/23(木) 10:02:44

 こんばんは！
ちょっろと私風に書いてみました。
相変わらずの私風です。。。(^^;
考え方はディクショナリーで親子関係を関連付けておいて
「私の親は誰」で親がいなくなるまで繰り返します。
ちょっと検証不足なので後は例によってアレンジしていただけますと幸甚です。
では、、、おやすみなさいzzzzzzzzzzzzzzzzzzzzzzzz

 Option Explicit
Sub 親子関係()
Dim MyDic As Object
Dim v As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim kk As Long
Dim x As Variant
Set MyDic = CreateObject("Scripting.Dictionary")
v = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 4).Value
For i = LBound(v, 1) + 1 To UBound(v, 1)
    MyDic(v(i, 1) & v(i, 2)) = v(i, 3) & v(i, 4)
Next
x = MyDic.Keys
ReDim z(0)
ReDim w(1 To UBound(x) + 1, 1 To 1)
For i = LBound(x) To UBound(x)
    私の親は誰 MyDic, x(i), z, False
    k = k + 1
    kk = 0
    For j = UBound(z) To LBound(z) Step -1
        If z(j) <> "" Then
            kk = kk + 1
            w(k, kk) = z(j)
        End If
    Next
    ReDim Preserve w(LBound(w, 1) To UBound(w, 1), 1 To UBound(w, 2) + 1)
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("a1").Resize(UBound(w, 1), UBound(w, 2)).Value = w
End With
Erase v, x, z, w
End Sub
Sub 私の親は誰(ByVal MyD As Object, ByRef MyKey As Variant, ByRef z As Variant, ByRef MyFlg As Boolean)
Static q As Variant
If MyFlg = False Then
    MyFlg = True
        ReDim q(0)
        q(0) = MyKey
End If
If MyFlg Then
    ReDim Preserve q(UBound(q) + 1)
    q(UBound(q)) = MyD(MyKey)
    z = q
    If MyD(MyKey) = "" Then Exit Sub
    私の親は誰 MyD, MyD(MyKey), z, True
End If
End Sub

    |[A]       |[B]   |[C]         |[D]     
 [1]|所属コード|所属名|親所属コード|親所属名
 [2]|         1|社長  |            |        
 [3]|         2|企画部|           1|社長    
 [4]|         3|総務部|           2|企画部  
 [5]|         4|営業  |           2|企画部  
 [6]|         5|営業1 |           4|営業

    |[A]  |[B]    |[C]    |[D]   
 [1]|1社長|       |       |      
 [2]|1社長|2企画部|       |      
 [3]|1社長|2企画部|3総務部|      
 [4]|1社長|2企画部|4営業  |      
 [5]|1社長|2企画部|4営業  |5営業1
（SoulMan） 2025/01/23(木) 19:43:20

 こういうの考えるのって面白いですよね

 '---------- 標準モジュール --------------
 Sub sample()
   Dim AllSection As New Collection
   Dim section As clsSection, parent As clsSection
   Dim aRow As Range
   '全セクションを生成
   For Each aRow In Range("A2", Cells(Rows.Count, "A").End(xlUp)).Rows
       Set section = New clsSection
       With section
          .ID = aRow.Cells(1, 1)
          .Name = aRow.Cells(1, 2)
          .parentID = aRow.Cells(1, 3)
       End With
       AllSection.Add section, section.ID
   Next
   '子供を登録
   For Each section In AllSection
       If Not IsEmpty(section.parentID) Then
          AllSection(section.parentID).children.Add section
       End If
   Next
   '書き出し
   For Each section In AllSection
       If IsEmpty(section.parentID) Then
          section.PrintChildren "F"
       End If
   Next
   Columns("F").TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, Tab:=True
 End Sub
 '---------- clsSection モジュール --------------
 Public ID As String, Name As String, parentID As Variant
 Public children As New Collection
 Function PrintChildren(col As Variant, Optional ByVal pre As String = "")
    Dim child As clsSection
    pre = pre & IIf(pre = "", "", vbTab) & Me.ID & vbTab & Me.Name
    Cells(Rows.Count, col).End(xlUp).Offset(1).Value = pre
    For Each child In children
        child.PrintChildren col, pre
    Next
 End Function
（´・ω・`） 2025/01/24(金) 10:43:23

 こんにちは！
いいねぇ、、いいねぇ、、いいですねぇ、、学校らしくなってきましたねぇ(^^;
わちきのロジックはCollectionなんかに置き換えてもそのままいけると思いますが、
それじゃ面白くないでしょうから、ここは敢えてオブジェクトを使わずに且つなるべく
現在の「親子関係」のロジックを変えないでもう一つアップしてみます。

 題して「親子関係ディクショナリーなんていらねぇ」ネーミングが例によって長い(^^;です。。。
お許しをm(__)m　相変わらずのわちき流でございます。
では、、では、、

 Option Explicit
Sub 親子関係ディクショナリーなんていらねぇ()
Dim v As Variant
Dim x As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim kk As Long
ReDim d(0)
ReDim g(0)
v = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 4).Value
For i = LBound(v, 1) + 1 To UBound(v, 1)
    x = Application.Match(v(i, 1) & v(i, 2), d, 0)
    If IsError(x) Then
        ReDim Preserve d(UBound(d) + 1)
        d(UBound(d)) = v(i, 1) & v(i, 2)
        ReDim Preserve g(UBound(g) + 1)
        g(UBound(g)) = v(i, 3) & v(i, 4)
    End If
Next
ReDim z(0)
ReDim w(1 To UBound(d), 1 To 1)
For i = LBound(d) + 1 To UBound(d)
    私の親は誰 d, g, d(i), z, False
    k = k + 1
    kk = 0
    For j = UBound(z) To LBound(z) Step -1
        If z(j) <> "" Then
            kk = kk + 1
            w(k, kk) = z(j)
        End If
    Next
    ReDim Preserve w(LBound(w, 1) To UBound(w, 1), 1 To UBound(w, 2) + 1)
Next
With Sheets("Sheet2")
    .Cells.Clear
    .Range("a1").Resize(UBound(w, 1), UBound(w, 2)).Value = w
End With
Erase v, d, g, z, w
End Sub
Sub 私の親は誰(ByVal d As Variant, ByVal g As Variant, ByRef MyKey As Variant, ByRef z As Variant, ByRef MyFlg As Boolean)
Dim x As Variant
Dim y As Variant
Static q As Variant
If MyFlg = False Then
    MyFlg = True
        ReDim q(0)
        q(0) = MyKey
End If
If MyFlg Then
    x = Application.Match(MyKey, d, 0)
    If Not IsError(x) Then
        y = g(x - 1)
    End If
    ReDim Preserve q(UBound(q) + 1)
    q(UBound(q)) = y
    z = q
    If y = "" Then Exit Sub
    私の親は誰 d, g, y, z, True
End If
End Sub
（SoulMan） 2025/01/24(金) 17:25:13

コメント返信：

[ 一覧(最新更新順) ]

[[20250108192652]] 『Excel VBAについて（親子関係から組織図を作る）氏x（neko） ページの最後に飛ぶ

[[20250108192652]]　『Excel VBAについて（親子関係から組織図を作る）氏x（neko）　ページの最後に飛ぶ