エクセルVBAでフォルダ構造リストをつくろう！

VBA
2021.02.22
この記事は約22分で読めます。

みなさん、こんにちは。

昨今はデータ社会と言われるだけあり、皆さんが取り扱うデータの量も増えているのではないでしょうか。かく言う私も、マイコンピュータやファイルサーバの容量がパンパンになり、ブルーレイや外付けHDD等のへの退避が余儀なくされております・・・しかし、退避させたファイルを探すのに、いちいちブルーレイや外付けHDDを接続するのも面倒です。そんな時に、フォルダ構造リストがあると便利です。今日は、そのフォルダ構造リストを自動作成するマクロの作り方をご紹介します。

フォルダ構造リストのイメージ

フォルダ構造リストのイメージは、こんな感じです。ツリーで示しているので、どのようなフォルダ構造になっているのか一目でわかり便利です。退避したブルーレイや外付けHDDのフォルダ構造リストを作り手元に保存しておけば、いちいちドライブを接続しなくても良いので便利です。また、エクセルで作成しているので「Ctrl+F」で検索をすればフォルダの場所を検索することもできるので、フォルダ数が多い場合も見つけるのが簡単です。

フォルダ構造リストの作り方

それでは、実際にフォルダ構造リストを作っていきましょう。

下準備（開発タブの表示）

本フォルダ構造リストは、エクセルのVBA（マクロ）で作成しますが、初期設定ではその作成画面が出ないようになっていますので、先ずはその設定を行いましょう（既に「開発」タブがエクセル画面にある方は実施不要、次に進んでください）。

エクセルのバージョンにより多少異なるかも知れませんが、以下の手順でマクロが使用可能になります。

１．エクセル画面上部の「ファイル」タブをクリックする

２．画面左下の「オプション」をクリックする

３．「Excelのオプション」ウィンドウの左側「リボンのユーザー設定」をクリックし、右側リボンのユーザー設定の「開発」の□チェックを入れる。

これで完成です！一度設定すれば、今後は実施不要です。

再帰計算でフォルダを探索する

フォルダを探索方法について、イメージを以下の図に示します。入り組んだ全てのフォルダを探索するためには、トップのフォルダから順に『「①サブフォルダの検索を行い、②あればそのフォルダの１つに移動する」を繰り返し、サブフォルダが無くなった時点で「③パスの書き出し」を行い「④⑤上位フォルダに戻る」』という一連の流れを繰り返すことでフォルダ構造を残さず取得することができます。これは、サブルーチンが自分自身を呼び出すことから「再帰計算」と呼ばれています。この方法を初めに思いついた人は天才ですね。ちなみに、この「再帰計算」でフォルダ構造を取得する方法については、色んなサイトで紹介されており、私も参考にしています。どちらかと言うと、本サイトのオリジナリティはツリー構造の作成するところにあります。

Private Sub tree(dfolder)

bookname = ActiveWorkbook.Name
macrosheet = ActiveSheet.Name

Dim FSO As New FileSystemObject
Dim objFiles As File
Dim objFolders As folder

start_row = 4

For Each objFolders In FSO.GetFolder(dfolder).SubFolders
    Call tree(objFolders.Path)
Next
'サブフォルダがある場合は更に探索（再帰計算）

If FSO.GetFolder(dfolder).SubFolders.Count = 0 Then
    Worksheets(macrosheet).Cells(cnt + start_row, 1).Value = dfolder
    cnt = cnt + 1
End If
'下層フォルダのパスを取得してセルに転記

End Sub

ツリー構造を作成する（パスを階層毎に分割する）

上記の再帰計算で、下図左側のようなパス一覧を取得することができますが、これだとフォルダのツリー構造は作れません。次は、このパスを階層ごとに分割する必要があります。その方法は簡単で、パスを階層を示す「￥」で区切って行けば良いわけです。

    For i = start_row To count1 + start_row - 1
        tmp0 = Replace(Worksheets(macrosheet).Cells(i, 1).Value, search_pass_top, "")
        tmp = Split(tmp0, "\")
        'パスを"\"で分割
    Next i

ツリー構造を作成する（ダブりを消す）

フォルダーの構造を作成しましたが、このままだと記載にダブりがありツリー構造になりません。そこで、以下で示すようなスクリプトでこのダブりを削除します。

    UBound_max = UBound_max + 1
    For n = 1 To UBound_max
        temp = Worksheets(macrosheet).Cells(start_row, n + 1).Value
        For i = 1 To count1
            If temp = Worksheets(macrosheet).Cells(i + start_row, n + 1).Value Then
                Worksheets(macrosheet).Cells(i + start_row, n + 1).Value = ""
            Else
                temp = Worksheets(macrosheet).Cells(i + start_row, n + 1).Value
            End If
        Next i
    Next n
    'ツリー構造を作るために、１つ下の行のフォルダが同じ名前であれば削除する

ツリー構造を作成する（罫線でフォルダを繋げる）

さて、この罫線の引き方がこのマクロのオリジナリティでもあるんですが、なんて説明しましょ・・・以下の図を見て頂くのが一番良いのですが、ポイントは２点で「フォルダ構造の下から１つずつ検索する」「検索した場所の左（下図Aの位置）と左下（下図Bの位置）の状態によって罫線を選ぶ」となっています。また、Flagをたてて同じ親フォルダの塊に突入した場合はFlagを0から1に、その塊から抜け出た場合は1から0に変更し罫線の判断に使います。これは、コードそのものを見て頂いた方がわかりやすいかも知れません。

    For temp3 = UBound_max To 2 Step -1
    flag_a = 0
    
      For temp2 = count1 + start_row - 1 To start_row Step -1
        temp = Worksheets(macrosheet).Cells(temp2, temp3 * 2 + 1).Value
        
        If temp <> "" Then
            If Worksheets(macrosheet).Cells(temp2, temp3 * 2 - 2 + 1).Value <> "" Then
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "─"
                    flag_a = 0
                Else
                    If flag_a = 1 Then
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "┬"
                        flag_a = 0
                    Else
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "─"
                        flag_a = 0
                    End If
                End If
            Else
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "└"
                    flag_a = 1
                Else
                    If flag_a = 1 Then
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "├"
                    Else
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "└"
                    End If
                    flag_a = 1
                End If
            End If
        Else
            If Worksheets(macrosheet).Cells(temp2, temp3 * 2 - 2 + 1).Value <> "" Then
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                    flag_a = 0
                Else
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                    flag_a = 0
                End If
            Else
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                    flag_a = 0
                Else
                    If flag_a = 1 Then
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "│"
                    Else
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                        flag_a = 0
                    End If
                End If
            End If
        
        End If
        
      Next temp2
      
      Worksheets(macrosheet).Columns(temp3 * 2 + 1).ColumnWidth = 25 'フォルダ名
      Worksheets(macrosheet).Columns(temp3 * 2).ColumnWidth = 3 '罫線

    Next temp3

マクロを動かしてみよう！

さて、それではマクロを動かしてみましょう。次のステップでお願いします。

１．エクセル上部の「開発」タブをクリックし、続いて「Visual Basic」をクリック。

２．出てきた画面左上の「Sheet1」を選び、右側の白い欄に下記のスクリプトをコピペ、その後保存する。

３・４は、一度実行すれば今後は実施不要です

３．画面上部「ツール」を選び、「参照設定」をクリックしてください。

４．参照設定画面の「Microsoft Scripting Runtime」にチェックを入れて「OK」をクリックする。画面右上の「×」でウィンドウを消す。

５．エクセル上部の「開発」タブをクリックし、続いて「マクロ」をクリック。

６．「Sheet1.make_tree」を選び「実行」をクリックする。

→これでマクロが実行されます！！

以下のスクリプトを上記２の画面にコピペしてください

Dim cnt As Integer

'Private Sub CommandButton1_Click()
Sub make_tree()

Dim ans As Integer

bookname = ActiveWorkbook.Name
macrosheet = ActiveSheet.Name
start_row = 4

Worksheets(macrosheet).Range(Worksheets(macrosheet).Cells(start_row, 1), Worksheets(macrosheet).Cells(65536, 200)).Value = ""
'↑書き込み領域のクリア（約100階層まで対応）

Dim WSH, mypath
Set WSH = CreateObject("shell.application")
Set mypath = WSH.browseforfolder(&O0, "探索するフォルダを選んでください", &H1 + &H10, "C:|")
'「Cドライブ」等の最上位フォルダは選べないです

If Not mypath Is Nothing Then MsgBox mypath.items.Item.Path
If Not mypath Is Nothing Then dfolder = mypath.items.Item.Path
Set WSH = Nothing
Set mypath = Nothing

Worksheets(macrosheet).Cells(2, 1).Value = dfolder
'探索フォルダをセルに転記

cnt = 0 'フォルダ数のカウントを初期化
Call tree(dfolder)

Worksheets(macrosheet).Cells(1, 1).Value = cnt
'フォルダ数をセルに格納

ans = MsgBox("フォルダ構造を作成しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")
Select Case ans
    Case vbYes
        Call folder
    'Case vbNo
End Select

End Sub

Private Sub tree(dfolder)

bookname = ActiveWorkbook.Name
macrosheet = ActiveSheet.Name

Dim FSO As New FileSystemObject
Dim objFiles As File
Dim objFolders As folder

start_row = 4

For Each objFolders In FSO.GetFolder(dfolder).SubFolders
    Call tree(objFolders.Path)
Next
'サブフォルダがある場合は更に探索（再帰計算）

If FSO.GetFolder(dfolder).SubFolders.Count = 0 Then
    Worksheets(macrosheet).Cells(cnt + start_row, 1).Value = dfolder
    cnt = cnt + 1
End If
'下層フォルダのパスを取得してセルに転記

End Sub

Private Sub folder()
    Dim tmp As Variant
    Dim UBound_max As Integer
    bookname = ActiveWorkbook.Name
    macrosheet = ActiveSheet.Name
    start_row = 4
    
    bookname = ActiveWorkbook.Name
        
    UBound_max = 0
    count1 = Worksheets(macrosheet).Cells(1, 1).Value
    
    Workbooks(bookname).Sheets(macrosheet).Activate
    
    search_pass = Worksheets(macrosheet).Cells(2, 1).Value
    temp_pass = Split(search_pass, "\")
    temp_pass = temp_pass(UBound(temp_pass))
    search_pass_top = Replace(search_pass, temp_pass, "")
    
    For i = start_row To count1 + start_row - 1
        tmp0 = Replace(Worksheets(macrosheet).Cells(i, 1).Value, search_pass_top, "")
        tmp = Split(tmp0, "\")
        'パスを"\"で分割

        For m = LBound(tmp) To UBound(tmp)
        'For m = LBound(tmp) + 1 To UBound(tmp)
            Worksheets(macrosheet).Cells(i, m + 2).Value = tmp(m)
            If UBound_max < UBound(tmp) Then
                UBound_max = UBound(tmp)
            End If
        Next m
        'フォルダ階層毎にセルに転記
        '最も深いフォルダ構造が何層か探索（UBound_maxに代入）
    Next i
        
    UBound_max = UBound_max + 1
    For n = 1 To UBound_max
        temp = Worksheets(macrosheet).Cells(start_row, n + 1).Value
        For i = 1 To count1
            If temp = Worksheets(macrosheet).Cells(i + start_row, n + 1).Value Then
                Worksheets(macrosheet).Cells(i + start_row, n + 1).Value = ""
            Else
                temp = Worksheets(macrosheet).Cells(i + start_row, n + 1).Value
            End If
        Next i
    Next n
    'ツリー構造を作るために、１つ下の行のフォルダが同じ名前であれば削除する
    
    For n = 1 To UBound_max
        Worksheets(macrosheet).Columns(n * 2).Insert
    Next n
    'ツリー構造を作るために、1行ごとに空列を挿入→"├"等を挿入する枠をつくる

    For temp3 = UBound_max To 2 Step -1
    flag_a = 0
    
      For temp2 = count1 + start_row - 1 To start_row Step -1
        temp = Worksheets(macrosheet).Cells(temp2, temp3 * 2 + 1).Value
        
        If temp <> "" Then
            If Worksheets(macrosheet).Cells(temp2, temp3 * 2 - 2 + 1).Value <> "" Then
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "─"
                    flag_a = 0
                Else
                    If flag_a = 1 Then
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "┬"
                        flag_a = 0
                    Else
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "─"
                        flag_a = 0
                    End If
                End If
            Else
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "└"
                    flag_a = 1
                Else
                    If flag_a = 1 Then
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "├"
                    Else
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "└"
                    End If
                    flag_a = 1
                End If
            End If
        Else
            If Worksheets(macrosheet).Cells(temp2, temp3 * 2 - 2 + 1).Value <> "" Then
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                    flag_a = 0
                Else
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                    flag_a = 0
                End If
            Else
                If Worksheets(macrosheet).Cells(temp2 + 1, temp3 * 2 - 2 + 1).Value <> "" Then
                    Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                    flag_a = 0
                Else
                    If flag_a = 1 Then
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = "│"
                    Else
                        Worksheets(macrosheet).Cells(temp2, temp3 * 2).Value = ""
                        flag_a = 0
                    End If
                End If
            End If
        
        End If
        
      Next temp2
      
      Worksheets(macrosheet).Columns(temp3 * 2 + 1).ColumnWidth = 25 'フォルダ名
      Worksheets(macrosheet).Columns(temp3 * 2).ColumnWidth = 3 '罫線

    Next temp3

Worksheets(macrosheet).Columns(1).ColumnWidth = 70 'フォルダ名
Worksheets(macrosheet).Columns(2).ColumnWidth = 3 '罫線
Worksheets(macrosheet).Columns(3).ColumnWidth = 25 'フォルダ名
    
End Sub

作るのが面倒な人・・・

さて、ここまでいかがでしたでしょうか？作るのが面倒？そんな方のために、作成済みファイルを用意しました。しかし、WEBからダウンロードした作成済みマクロの実行は、本来結構リスキーです（ちなみに、私なら絶対にやりません）。そのうえで、もし使う方は以下をどうぞ。このファイルには、スタートボタンを付けていますので、１クリックで開始できるので便利です！

フォルダ構造確認ダウンロード

まとめ

エクエルVBAでフォルダ構造リスト作成マクロを作ってみましたが、結構な大作となりました・・・きっと、もっとスマートに書く方法もあるのだと思いますが、とりあえず使えるものが出来たので満足しています。これまで、手動でフォルダ構造リストを作っていた方は、是非使ってみて頂きたいです。

免責事項

・本サイトの内容は、予告なしに変更・追加・削除等をする場合があります。
・本サイトおよび管理人は、本サイトの利用者が、本サイトの内容に依拠し、または本サイトの情報を信頼して行った行動等により被った、いかなる生命、身体、財産上の損失又は損害についても責任を負いかねます。

コメント

タイトルとURLをコピーしました