[[20230928163125]]　『フォルダパスをツリー化表示させる方法がわかりま』（たか）　ページの最後に飛ぶ

『フォルダパスをツリー化表示させる方法がわかりません』（たか）

オンラインストレージのフォルダパスをツリー化して管理したいです。

オンラインストレージのフォルダパスは以下の形式(Excel)で抽出したのですが、ツリー化が出来なくて困っています。

やり方がわかる方がいらっしゃいましたらご教示ください。

オンラインストレージのフォルダパス
A/a/01/TEST1
A/a/01/TEST2
A/a/01/TEST3
A/a/02/TEST1
A/a/02/TEST2

Excelで表示させたいツリー構造

A━a┳01┰TEST1

    ┃  ┣TEST2
    ┃  ┗TEST3
　　┃
    ┗02┰TEST1
        ┗TEST2

なお、ExcelのSmartArtより階層構造を試しましたが、上記パスをコピペする全てのパスが選択されてしまいツリー構造になりませんでした。

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

 以前、xyzさんに教えていただきました。
https://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html
（マナ） 2023/09/28(木) 16:57:13

マナさん、コメントいただきまして誠にありがとうございます。

当方、VBAに疎いですがリンク先を参照させていただきました。
その中で質問ですが、今回のケースではオンラインストレージ上のファイル一覧の取得は行わず、
手元にあるExcelのデータ(フォルダパス)をツリー構造に変更することが目的となります。

ご共有いただいた内容は、上記目的と合致しているという理解で合っておりますでしょうか。
（たか） 2023/09/28(木) 17:20:36

 失礼しました。そういう使い方はできません。
（マナ） 2023/09/28(木) 17:52:22

 SmartArtの階層構造でいいなら、一度ピボットでデータを整理してからやったらどうでしょう？

 データタブの区切り位置機能を使って/でセルごとに分け、タイトル行を追加する。

 例）	A	B	C	D
 1	第1階層	第2階層	第3階層	第4階層
 2	A	a	01	TEST1
 3	A	a	01	TEST2
 4	A	a	01	TEST3
 5	A	a	02	TEST1
 6	A	a	02	TEST2

 ピボットを作る。タイトル行込みで全データを選択し、挿入タブからピボットテーブルを選択。
 全データを「行」の位置に入れる。
 ピボットの表内のセルをどこでもいいので選択。タブにデザインと言うのが出るので、そこを開く。
 以下を設定
 　小計：小計を表示しない
 　総計：行と列の集計を行わない
 　レポートのレイアウト：アウトライン形式で表示

 あとは以下のURLのやり方参照で出来るかと思います。
https://extan.jp/?p=9697

（Q田） 2023/09/29(金) 14:22:28

 こんにちは。

 > その中で質問ですが、今回のケースではオンラインストレージ上のファイル一覧の取得は行わず、
 > 手元にあるExcelのデータ(フォルダパス)をツリー構造に変更することが目的となります。
 ご紹介のありました井上さんのサイトを探せば、フォルダ一覧をツリー表示できるものがあると思います。
 抽出も含めて対応できる既存の"枯れた"（つまり、多くの方の使用に耐えた）ツールがあるのですから、
 こうしたものを援用したほうがよいと思います。

 さはさりながら、お題の、テキストデータを元にして、ツリーを表示するものを参考までに示します。

 Windows標準のTreeコマンドと同様の出力形式によるものを作成してみました。
 （こちらが一般的な形式だと思います。）
 提示された形式とやや違いますが、参考にしてください。

 ちゃちゃっと作れる感じはしません。少なくとも面倒なものではあるでしょう。
 修正事項があるとしても、明らかなバグ対応以外は時間を費やす積りはありませんので、
 予め申し上げておきます。

 <<データと作成例>>
 A列(元データ)           C列(結果)
 A/a/01/TEST1            A
 A/a/01/TEST2            ┣ a
 A/a/01/TEST3            ┃  ┣ 01
 A/a/02/TEST1            ┃  ┃  ┣ TEST1
 A/a/02/TEST2            ┃  ┃  ┣ TEST2
 A/b/01/TEST1            ┃  ┃  ┗ TEST3
 A/b/01/TEST2            ┃  ┗ 02
 A/b/01/TEST3            ┃      ┣ TEST1
 A/b/02/TEST1            ┃      ┗ TEST2
 A/b/02/TEST2            ┣ b
 A/c/01/TEST1            ┃  ┣ 01
 B/a/01/test             ┃  ┃  ┣ TEST1
 B/b/01/test             ┃  ┃  ┣ TEST2
                         ┃  ┃  ┗ TEST3
                         ┃  ┗ 02
                         ┃      ┣ TEST1
                         ┃      ┗ TEST2
                         ┗ c
                             ┗ 01
                                 ┗ TEST1
                         B
                         ┣ a
                         ┃  ┗ 01
                         ┃      ┗ test
                         ┗ b
                             ┗ 01
                                 ┗ test

 <<参考コード>>
 Option Explicit

 Const letter1$ = "┣ "
 Const letter2$ = "┗ "
 Const letterC$ = "┃  "
 Const letterD$ = "    "

 Dim foldrs      As Object
 Dim subfolders  As Object

 Dim line_continuous(1 To 10) As Boolean  '接続線を書くか否か。なお、階層は上限10とした。（適宜修正のこと）
 Dim pos As Long     '結果の書き込み位置

 Sub main()
     Set foldrs = CreateObject("Scripting.Dictionary")
     Set subfolders = CreateObject("Scripting.Dictionary")

     Call set_foldrs     'foldrs: すべてのフォルダをkeyとする辞書(itemはEmpty)を作成

     Call set_subfolders '辞書 subfolders を作成
                         'key : 各folder
                         'item: その直下のサブフォルダからなる辞書

     Columns("C").ClearContents  '書き出す列(C)を初期化
     pos = 0                     '結果の書き出し行の初期化

     Dim root  As Variant
     Dim roots As Object
     Set roots = get_roots       '最上位のフォルダを得る

     'Tree図をC列に書き出す
     For Each root In roots
         pos = pos + 1: Cells(pos, "C") = root
         Call recursion(root, 1)
     Next
 End Sub

 Function set_foldrs()
     Dim s$, ary, t$
     Dim k&, j&
     For k = 1 To Cells(Rows.Count, "A").End(xlUp).Row
         s = Cells(k, "A")
         ary = Split(s, "/")
         For j = 0 To UBound(ary)
             If j = 0 Then t = ary(j) Else t = t & "/" & ary(j)
             foldrs(t) = Empty
         Next
     Next
 End Function

 Function set_subfolders()
     Dim re As Object
     Dim dic As Object
     Dim fldr, fldr2
     Dim k&

     Set re = CreateObject("VBScript.RegExp")

     For Each fldr In foldrs
         re.Pattern = "^" & fldr & "\/" & "[^/]+$"
         For Each fldr2 In foldrs
             If re.test(fldr2) Then
                 If dic Is Nothing Then
                     Set dic = CreateObject("Scripting.Dictionary")
                 End If
                 dic(fldr2) = Empty
             End If
         Next
         Set subfolders(fldr) = dic
         Set dic = Nothing
     Next
 End Function

 Function get_roots() As Object
     Dim dic As Object
     Dim k&, s$
     Set dic = CreateObject("Scripting.Dictionary")
     For k = 1 To Cells(Rows.Count, "A").End(xlUp).Row
         s = Cells(k, "A")
         dic(Split(s, "/")(0)) = Empty
     Next
     Set get_roots = dic
 End Function

 Function recursion(folder As Variant, depth As Long)
     Dim a As Object
     Dim c2&
     Dim i&, k&
     Dim elem
     Dim elem2
     Dim ary
     Dim s$
     If Not subfolders(folder) Is Nothing Then
         Set a = subfolders(folder)
         c2 = a.Count
         line_continuous(depth) = True
         i = 0
         For Each elem In a.keys
             ary = Split(elem, "/")
             elem2 = ary(UBound(ary))
             i = i + 1

             s = ""          '接続線
             For k = 1 To depth - 1
                 If line_continuous(k) = True Then
                     s = s & letterC      ' "┃  "
                 Else
                     s = s & letterD      ' "    "
                 End If
             Next

             If i = c2 Then
                 pos = pos + 1: Cells(pos, "C") = s & letter2 & elem2
             Else
                 pos = pos + 1: Cells(pos, "C") = s & letter1 & elem2
             End If

             '最後のフォルダについては、接続線は不要
             If i = c2 Then line_continuous(depth) = False
             Call recursion(elem, depth + 1)  
         Next
     End If
 End Function

（xyz） 2023/09/29(金) 14:47:26

井上さん?
（?） 2023/09/29(金) 15:21:28

マナさんが以下の日時でコメントしたサイトの管理人さんですね

（マナ） 2023/09/28(木) 16:57:13

https://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html

ページ下部にこうあります

（ねじねじ）さん了解です。
（?） 2023/09/29(金) 17:07:48

 ●一番手っ取り早いのは、
   コマンドプロンプトで Treeコマンド を使うことです。
   具体的には、
     Tree 対象とするルートフォルダのパス
   とすれば、その配下のフォルダのTree図が表示されます。

 ●また、
     Tree 対象とするルートフォルダのパス  > tree図.txt
   などと、テキストファイルにリダイレクトすれば、
   テキストファイルに結果を書き込めます。

 http://office-qa.com/win/win186.htm
 を参照。（何か結果図がおかしい気もします。）

 # ちなみに、提示したコードは、
 # 以前に同種の質問があった際の私の回答をもとに、今回新たに作成したものです。
 # 今後、同様の質問があった場合に、閲覧されている方に活かしていただければと思います。
（xyz） 2023/09/29(金) 22:48:26

 >    Tree 対象とするルートフォルダのパス  > tree図.txt
 >    などと、テキストファイルにリダイレクトすれば、
 >    テキストファイルに結果を書き込めます。

 マクロにしてみました。
 念のため、空フォルダに、マクロブックを保存してください。
 A列に、パスが列挙されている前提です。

 Sub test()
    Dim r As Range, e
    Dim p As String, bat As String

    Set r = Range("a1", Cells(Rows.Count, 1).End(xlUp))

    p = ThisWorkbook.Path & "\"
    bat = p & "tree.bat"

    Open bat For Output As #1
        For Each e In r.Value
            Print #1, "md ""tmp\" & Replace(e, "/", "\") & """"
        Next
        Print #1, "tree tmp > """ & p & "tree図.txt"""
        Print #1, "rd /s/q tmp"
    Close #1

    CreateObject("wscript.shell").Run """" & bat & """", 0, True
    Kill bat

 End Sub
（マナ） 2023/10/02(月) 08:52:02

 興味があったので作ってみました
 参考出品
 イミディエイトウインドウに書き出しますがごそこは勘弁ください

 '-------- 標準モジュール ----------------------
    Sub sample()
      Dim tree As clsTree, aCell As Range
      Set tree = New clsTree
      tree.Delimiter = "/"
      For Each aCell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
         tree.AddTree aCell.Value
      Next
      tree.PrintTree
    End Sub
 '-------- クラスモジュール clsTree ------------
    Public Name As String
    Public SubTrees As Collection
    Public Items As Collection
    Public Delimiter As String
    Private Sub Class_Initialize()
        Set SubTrees = New Collection
        Set Items = New Collection
        Name = "Root"
        Delimiter = "\"
    End Sub
    Public Sub AddTree(newName As String)
        Dim path() As String, tree As clsTree
        path = Split(newName, Delimiter)
        Set tree = Me
        If UBound(path) = 0 Then
           tree.Items.Add path(0), path(0)
        Else
           On Error GoTo AddNew
              Set tree = SubTrees(path(0))
           On Error GoTo 0
           tree.AddTree Mid(newName, Len(path(0)) + 2)
        End If
        Exit Sub
    AddNew:
        tree.SubTrees.Add New clsTree, path(0)
        tree.SubTrees(path(0)).Name = path(0)
        tree.SubTrees(path(0)).Delimiter = Delimiter
        Resume
    End Sub
    Public Sub PrintTree(Optional ByVal pre As String = "")
        Dim tree As clsTree
        Dim i As Long, nSubTree As Long, nItem As Long
        nSubTree = SubTrees.Count: nItem = Items.Count
        For i = 1 To nSubTree
            Debug.Print pre & IIf(i = nSubTree And nItem = 0, "┗■", "┣■") & SubTrees(i).Name
            SubTrees(i).PrintTree pre & IIf(i = nSubTree And nItem = 0, "　", "┃")
        Next
        For i = 1 To nItem
            Debug.Print pre & IIf(i = nItem, "┗□", "┣□") & Items(i)
        Next
    End Sub

 xyzさん 2023/09/29(金) 14:47:26 のサンプルデータで実行するとこうなります
 ┣■A
 ┃┣■a
 ┃┃┣■01
 ┃┃┃┣□TEST1
 ┃┃┃┣□TEST2
 ┃┃┃┗□TEST3
 ┃┃┗■02
 ┃┃　┣□TEST1
 ┃┃　┗□TEST2
 ┃┣■b
 ┃┃┣■01
 ┃┃┃┣□TEST1
 ┃┃┃┣□TEST2
 ┃┃┃┗□TEST3
 ┃┃┗■02
 ┃┃　┣□TEST1
 ┃┃　┗□TEST2
 ┃┗■c
 ┃　┗■01
 ┃　　┗□TEST1
 ┗■B
 　┣■a
 　┃┗■01
 　┃　┗□test 
 　┗■b
 　　┗■01
 　　　┗□test 
（´・ω・`） 2023/10/02(月) 12:14:01

皆様、ご教示いただきまして誠にありがとうございます。
お陰様で階層データ化の生成を行えることが出来ました
（たか） 2023/10/12(木) 11:51:02

マナさん、ご教示いただきましてありがとうございます。
下記マクロを実行することで階層データ化および抽出することが出来ました。

もう一点質問となります。
初歩的な質問で恐縮ですが、batファイルを生成しない/叩かないで変換する方法はあるのでしょうか？
可能であれば、マクロが有効となったExcel上で動作が完結できればなと思っております。

Sub test()

    Dim r As Range, e
    Dim p As String, bat As String
    Set r = Range("a1", Cells(Rows.Count, 1).End(xlUp))
    p = ThisWorkbook.Path & "\"
    bat = p & "tree.bat"
    Open bat For Output As #1
        For Each e In r.Value
            Print #1, "md ""tmp\" & Replace(e, "/", "\") & """"
        Next
        Print #1, "tree tmp > """ & p & "tree図.txt"""
        Print #1, "rd /s/q tmp"
    Close #1
    CreateObject("wscript.shell").Run """" & bat & """", 0, True
    Kill bat
 End Sub
（マナ） 2023/10/02(月) 08:52:02
（たか） 2023/10/12(木) 11:54:14

 > batファイルを生成しない/叩かないで変換する方法はあるのでしょうか？

 xyzさん、（´・ω・`）さんから提示されていますが…
（マナ） 2023/10/12(木) 18:14:43

コメント返信：

[ 一覧(最新更新順) ]

[[20230928163125]] 『フォルダパスをツリー化表示させる方法がわかりま』（たか） ページの最後に飛ぶ

[[20230928163125]]　『フォルダパスをツリー化表示させる方法がわかりま』（たか）　ページの最後に飛ぶ