指定したフォルダの全ての階層のフォルダ名・サブフォルダ名・ファイル名を取得（Excel VBA）

【本日のミッション】

Excel VBAにて指定したフォルダの全ての階層のフォルダ名・サブフォルダ名・ファイル名を取得し、一覧表を作成せよ。

以前お話ししました

指定したフォルダ内のサブフォルダのフォルダ名を全部取得（Excel VBA）
指定したフォルダ内とサブフォルダ内全てのファイル名を取得（Excel VBA）

から更に進歩です！！

セルB3に、フォルダ・サブフォルダ・ファイル名を取得したいフォルダのパスを入力
セルB6に、一覧表を作りたいセル範囲の左上のセルアドレスを入力
<フォルダ・ファイル名一覧作成>ボタンをポチっと

すると、セルB6に入力したアドレスに、ファイル・フォルダ一覧表が完成！
という、夢のようなVBAの作成です♪

対象フォルダパス「C:\VBA」の中には下記フォルダ・ファイルが入っています。

完成した表は下記の通りになります。

フォルダやファイルの構造が一目でわかって便利な表です。

■スポンサーリンク

Excelマクロ有効ブック（.xlsm）のファイルを新規作成します。

そのファイルのシートに下記の通り、フォルダのパスを入力するセル（B3）、取得したファイル名を書き出すセル（B6）、VBAを登録するボタンを準備します。

フォルダパス（B3)には、取得したいフォルダ・ファイルが入っているフォルダのフルパスを入力します。

Alt＋F11でVsual Basic Editerを起動します。

［挿入］－［標準モジュール］で新規モジュールを作成し、下記の通りコードを記入します。

'【変数】
Dim s_row As Long '開始行
Dim s_col As Long '開始列
Dim e_col As Long '終了列

Sub 指定したフォルダ内の全階層のフォルダ名とファイル名で一覧作成()
    '【変数】
    'ファイル・シート関連関連
    Dim FSO As Object   'FileSystemObject
    Dim Pt As String    '対象フォルダパス
    '行列関連
    Dim t_row As Long   '対象行
    Dim t_col As Long   '対象列

    Application.ScreenUpdating = False '画面表示の停止

    '■変数セット
    s_row = Range(Range("B6")).Row    '開始行
    s_col = Range(Range("B6")).Column '開始行
    t_row = s_row + 1                 '対象行
    t_col = s_col                     '対象列
    e_col = t_col                     '最終列

    '■FileSystemObjectのインスタンス化
    Set FSO = CreateObject("Scripting.FileSystemObject")

    '■対象フォルダパス（最後に「\」が無ければ「\」を付ける）
    If Right(Pt, 1) = "\" Then
        Pt = Range("B3")
    Else
        Pt = Range("B3") & "\"
    End If

    '■対象フォルダの有無の確認
    If Not FSO.FolderExists(Pt) Then
        MsgBox ("ご指定のフォルダは存在しません。")
        Exit Sub
    End If

    '■前回データのクリア
    Rows(s_row & ":" & Cells.Rows.Count).Clear

    '■再帰処理開始
    Call フォルダファイル名取得(FSO, Pt, t_row, t_col)

    '■列幅の調整
    Range(Columns(t_col), Columns(Columns.Count)).ColumnWidth = 3
    Range(Columns(e_col), Columns(e_col + 2)).EntireColumn.AutoFit

    '■サイズ、更新日時の罫線設定
    Range(Cells(s_row, e_col + 1), Cells(t_row - 1, e_col + 1)).BorderAround Weight:=xlHairline, LineStyle:=xlContinuous
    Range(Cells(s_row, t_col), Cells(t_row - 1, e_col + 2)).BorderAround LineStyle:=xlContinuous

    '■見出し設定
    Cells(s_row, s_col) = "フォルダ・ファイル名"
    Cells(s_row, e_col + 1) = "サイズ"
    Cells(s_row, e_col + 2) = "更新日時"
    Range(Cells(s_row, e_col + 1), Cells(s_row, e_col + 2)).HorizontalAlignment = xlCenter

    Application.Goto reference:=Range("A1"), scroll:=True
    Range(Range("B3"), Range("XFD2")).ClearFormats

    '■オブジェクトの解放
    Set FSO = Nothing

    Application.ScreenUpdating = False '画面表示の再開

End Sub

Sub フォルダファイル名取得(FSO As Object, Pt As String, t_row As Long, t_col As Long)

    '【変数】
    Dim s_Fd As Object 'サブフォルダ
    Dim Fl As Object 'ファイル
    Dim strSplit() As String

    '■最終列が増えた場合、サイズ列の前に1列追加
    If t_col > e_col Then
        Columns(t_col).Insert Shift:=xlToRight
        e_col = t_col
    End If

    '■サブフォルダの取得
    For Each s_Fd In FSO.GetFolder(Pt).SubFolders '変数S_FdにFdフォルダ内のフォルダ名を順に取得

        '□サブフォルダ名転記
        Cells(t_row, t_col) = s_Fd.Name

        '□サブフォルダにハイパーリンクを設定
        ActiveSheet.Hyperlinks.Add _
            Anchor:=Cells(t_row, t_col), _
            Address:=s_Fd.Path, _
            TextToDisplay:=s_Fd.Name

        '□サブフォルダ名罫線設定
        Call 罫線(t_row, t_col)

        t_row = t_row + 1

        '□再帰処理
        Call フォルダファイル名取得(FSO, s_Fd.Path, t_row, t_col + 1)
    Next s_Fd

    '■ファイル名の取得
    For Each Fl In FSO.GetFolder(Pt).Files

        '□ファイル名転記
        Cells(t_row, t_col) = Fl.Name

        '■Excel・csvファイルはハイパーリンク設定
        strSplit = Split(Fl.Path, ".")

        If UBound(strSplit) > 0 Then
            Select Case LCase(strSplit(UBound(strSplit)))
                Case "xls", "xlsx", "xlsm", "csv"
                    ActiveSheet.Hyperlinks.Add _
                        Anchor:=Cells(t_row, t_col), _
                        Address:=Fl.Path, _
                        TextToDisplay:=Fl.Name
            End Select
        End If

        '□ファイルサイズ・更新日時転記
        Cells(t_row, e_col + 1) = WorksheetFunction.RoundUp(Fl.Size / 1024, 0)
        Cells(t_row, e_col + 1).NumberFormatLocal = "#,##0 ""KB"""
        Cells(t_row, e_col + 2) = Fl.DateLastModified
        Cells(t_row, e_col + 2).NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"

        '■ファイル名罫線
        Call 罫線(t_row, t_col)

        t_row = t_row + 1
    Next Fl

    '■オブジェクトの解放
    Set s_Fd = Nothing
    Set Fl = Nothing

End Sub

Sub 罫線(t_row As Long, t_col As Long)

    '■左の罫線
    If t_col > s_col Then
        With Range(Cells(t_row, s_col), Cells(t_row, t_col - 1))
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
        End With
    End If

    '■上の罫線
    With Range(Cells(t_row, t_col), Cells(t_row, e_col + 2))
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
    End With

End Sub

元のExcelの画面に戻り、ボタン用に作ったオブジェクトを選択し、右クリックー［マクロの登録］を選択します。