EXCEL VBA フォルダ階層図作成ツール コード crossfish21

コード

シート埋め込みコード

Private Sub CheckSelectFileType_Change()  ' 「出力するファイル種別を指定する」チェックのON/OFF時の処理

    With ThisWorkbook.Worksheets("階層図作成")
        If .CheckSelectFileType.Value = True Then
            .CheckXlsx.Enabled = True
            .CheckXlsm.Enabled = True
            .CheckXls.Enabled = True
            .CheckDocx.Enabled = True
            .CheckDoc.Enabled = True
            .CheckTxt.Enabled = True
            .CheckJpg.Enabled = True
            .CheckPng.Enabled = True
            .CheckPdf.Enabled = True
        Else
            .CheckXlsx.Enabled = False
            .CheckXlsx.Enabled = False
            .CheckXlsm.Enabled = False
            .CheckXls.Enabled = False
            .CheckDocx.Enabled = False
            .CheckDoc.Enabled = False
            .CheckTxt.Enabled = False
            .CheckJpg.Enabled = False
            .CheckPng.Enabled = False
            .CheckPdf.Enabled = False
        End If
    End With

End Sub

---

メインコード

Option Explicit
Option Base 1

Dim objFSO As FileSystemObject         ' FSO
Const maxRetsu As Long = 200           ' データの入る最大列数
Dim maxDataRetsu As Long               ' データのある最大列
Dim maxDataGyou As Long                ' データのある最大行
Dim wsKaisouzuSakusei As Worksheet     ' 「階層図作成」シート
Dim wsOutput As Worksheet              ' 階層図出力シート
Dim outputGyou As Long                 ' 出力シートの現在行数
Dim strStartPath As String             ' 階層図作成の基点となるフォルダのパス
Dim selectFileType() As String         ' 出力するファイルの種類のうち、選択されたものを格納する配列
Dim pathRetsu As Long                  ' 「パス」を出力する列番号
Dim nameRetsu As Long                  ' 「フォルダ名・ファイル名」を出力する列番号
Dim typeRetsu As Long                  ' 「種別」を出力する列番号
Dim sizeRetsu As Long                  ' 「サイズ」を出力する列番号
Dim lastmodifyRetsu As Long            ' 「最終更新日」を出力する列番号
Dim kaisouStratRetsu As Long           ' 階層図の作成を始める列番号


Sub CreateKaisouzu()  ' 階層図作成処理

    Dim folderRetsu As Long               ' フォルダの場合の出力列
    Dim fileRetsu As Long                 ' ファイルの場合の出力列
    Dim sortString As String              ' パスのソート用文字列
    Dim yenPosition As Long               ' パスの文字列内の「￥」の位置
    Dim i As Long

    Set wsKaisouzuSakusei = ThisWorkbook.Worksheets("階層図作成")
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Call CheckInput   ' 入力内容チェック処理の呼び出し

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Worksheets.Add   ' 新しいシートを追加し、このシートに階層図を作成
    Set wsOutput = ActiveSheet
    wsOutput.Range(Columns(1), Columns(maxRetsu)).NumberFormatLocal = "@"  ' セルの書式設定を文字列に
    pathRetsu = 0
    nameRetsu = 0
    typeRetsu = 0
    sizeRetsu = 0
    lastmodifyRetsu = 0
    kaisouStratRetsu = 0
    maxDataRetsu = 1

    With wsKaisouzuSakusei   ' 出力する列を設定
        If .Cells(7, 4).Value <> "" Then
            pathRetsu = .Cells(7, 4).Value  ' 「パス」を出力する列番号
        End If
        If .Cells(8, 4).Value <> "" Then
            nameRetsu = .Cells(8, 4).Value  ' 「フォルダ名・ファイル名」を出力する列番号
        End If
        If .Cells(9, 4).Value <> "" Then
            typeRetsu = .Cells(9, 4).Value  ' 「種別」を出力する列番号
        End If
        If .Cells(10, 4).Value <> "" Then
            sizeRetsu = .Cells(10, 4).Value  ' 「パス」を出力する列番号
        End If
        If .Cells(11, 4).Value <> "" Then
            lastmodifyRetsu = .Cells(11, 4).Value  ' 「最終更新日」を出力する列番号
        End If
        If .Cells(12, 4).Value <> "" Then
            kaisouStratRetsu = .Cells(12, 4).Value  ' 階層図の作成を始める列番号
        End If

    End With

    With wsOutput  ' 出力シートのタイトル部の設定
        If pathRetsu <> 0 Then
            .Cells(1, pathRetsu).Value = "Path"
            .Cells(1, pathRetsu).Interior.Color = 15773696
        End If
        If nameRetsu <> 0 Then
            .Cells(1, nameRetsu).Value = "フォルダ名・ファイル名"
            .Cells(1, nameRetsu).Interior.Color = 15773696
        End If
        If typeRetsu <> 0 Then
            .Cells(1, typeRetsu).Value = "種別"
            .Cells(1, typeRetsu).Interior.Color = 15773696
        End If
        If sizeRetsu <> 0 Then
            .Cells(1, sizeRetsu).Value = "サイズ"
            .Cells(1, sizeRetsu).Interior.Color = 15773696
        End If
        If lastmodifyRetsu <> 0 Then
            .Cells(1, lastmodifyRetsu).Value = "最終更新日"
            .Cells(1, lastmodifyRetsu).Interior.Color = 15773696
        End If
        If kaisouStratRetsu <> 0 Then
            .Cells(1, kaisouStratRetsu).Value = "ここから階層図"
            .Cells(1, kaisouStratRetsu).Interior.Color = 49407
        End If

        maxDataRetsu = wsOutput.Cells(1, wsOutput.Columns.Count).End(xlToLeft).Column
        wsOutput.Range(Cells(1, 1), Cells(1, maxDataRetsu)).Columns.AutoFit   ' セル幅の自動調整
    End With

    folderRetsu = kaisouStratRetsu
    fileRetsu = kaisouStratRetsu + 1
    outputGyou = 2

    Call FileFolderSearch(strStartPath, folderRetsu, fileRetsu)  ' ファイル・フォルダの検索処理を呼び出し

    ' パスのソートをする
    If pathRetsu <> 0 And typeRetsu <> 0 Then  ' ソートを実行するのは「パス」と「種別」の出力指定があった場合のみ
        With wsOutput

            .Columns(1).Select
            Selection.Insert   ' ソートのために１列追加
            .Columns(1).NumberFormatLocal = "@"  ' セルの書式設定を文字列に

            outputGyou = 2
            Do While .Cells(outputGyou, pathRetsu).Value <> ""
                .Cells(outputGyou, 1).Value = .Cells(outputGyou, pathRetsu + 1).Value
                sortString = .Cells(outputGyou, 1).Value
                If .Cells(outputGyou, typeRetsu + 1).Value = "File" Then ' 種別がFileだった場合
                    yenPosition = InStrRev(sortString, "\")  ' 文字列の後方から「￥」を検索
                    sortString = Left(sortString, yenPosition) & " " & Right(sortString, Len(sortString) - yenPosition)
                    ' 最後にある「￥」の後に、半角スペースを入れる
                    .Cells(outputGyou, 1).Value = sortString
                End If
                outputGyou = outputGyou + 1
            Loop

            .Range(Cells(2, 1), Cells(maxDataGyou, maxRetsu)).Sort key1:=.Cells(1, 1) ' 加工したパス名を元にソートする
            .Columns(1).Delete

        End With
    End If

    wsOutput.Range(Cells(2, maxDataRetsu + 1), Cells(maxDataGyou, maxRetsu)).Interior.ColorIndex = 0
    ' データの無い部分のセル色を無色に
    wsOutput.Cells(2, 1).Select
    ActiveWindow.FreezePanes = True  ' １行目で枠固定

    wsOutput.Range(Cells(1, 1), Cells(maxDataGyou, maxDataRetsu)).Borders.LineStyle = True

    If ThisWorkbook.Worksheets("階層図作成").CheckHyperLink.Value = True Then  ' パスにハイパーリンクを付与する場合
        If pathRetsu <> 0 Then
            For i = 2 To maxDataGyou
                wsOutput.Hyperlinks.Add anchor:=wsOutput.Cells(i, pathRetsu), Address:=wsOutput.Cells(i, pathRetsu)
            Next i
        Else
            MsgBox "パスの出力指定がされていないので、ハイパーリンクの付与は実施しません"
        End If
    End If

    wsOutput.Name = "階層図"
    wsOutput.Move  ' 階層図のシートを新規ブックとして切り離し

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "完了"

End Sub


Sub FileFolderSearch(strStartPath As String, folderRetsu As Long, fileRetsu As Long) ' ファイル・フォルダの検索を実行

    Dim objFile As Object           ' ファイル
    Dim objFolder As Object         ' フォルダ
    Dim objSubFolder As Object      ' サブフォルダ
    Dim i As Long
    Dim strFileName As String       ' 拡張子を指定したファイル名の文字列
    Dim bolMatch As Boolean         ' 指定ファイル種別に該当しているかどうか

    With objFSO

        Set objFolder = .GetFolder(strStartPath)

        If ThisWorkbook.Worksheets("階層図作成").CheckChangeColor.Value = True Then  ' フォルダとファイルで色分けする場合
            wsOutput.Range(Cells(outputGyou, 1), Cells(outputGyou, maxRetsu)).Interior.Color = 13434777
        End If

        ' フォルダのデータを出力
        If pathRetsu <> 0 Then
            wsOutput.Cells(outputGyou, pathRetsu).Value = .GetFolder(objFolder).Path
        End If
        If nameRetsu <> 0 Then
            wsOutput.Cells(outputGyou, nameRetsu).Value = .GetFolder(objFolder).Name
        End If
        If typeRetsu <> 0 Then
            wsOutput.Cells(outputGyou, typeRetsu).Value = "Folder"
        End If
        If sizeRetsu <> 0 Then
            wsOutput.Cells(outputGyou, sizeRetsu).Value = .GetFolder(objFolder).Size
        End If
        If lastmodifyRetsu <> 0 Then
            wsOutput.Cells(outputGyou, lastmodifyRetsu).Value = .GetFolder(objFolder).DateLastModified
        End If
        If kaisouStratRetsu <> 0 Then
            wsOutput.Cells(outputGyou, folderRetsu).Value = .GetFolder(objFolder).Name
        End If

        If maxDataRetsu < folderRetsu Then  ' 最大データ列の更新
            maxDataRetsu = folderRetsu
        End If

        maxDataGyou = outputGyou


        ' フォルダ内のファイルのデータを出力
        For Each objFile In objFolder.Files

            If ThisWorkbook.Worksheets("階層図作成").CheckSelectFileType.Value = True Then
            ' ファイル種別の指定がある場合
                bolMatch = False
                For i = 1 To UBound(selectFileType) - 1  ' 現在のobjFileが、指定ファイル種別に該当しているかをチェック
                    strFileName = "*" & selectFileType(i)
                    If .GetFile(objFile).Name Like strFileName Then
                        bolMatch = True
                        Exit For
                    End If
                Next i
                If bolMatch = True Then  ' 現在のobjFileが、指定ファイル種別に該当している場合
                    outputGyou = outputGyou + 1
                    maxDataGyou = outputGyou

                    If ThisWorkbook.Worksheets("階層図作成").CheckChangeColor.Value = True Then  ' フォルダとファイルで色分けする場合
                        wsOutput.Range(Cells(outputGyou, 1), Cells(outputGyou, maxRetsu)).Interior.Color = 9961471
                    End If

                    If pathRetsu <> 0 Then
                        wsOutput.Cells(outputGyou, pathRetsu).Value = .GetFile(objFile).Path
                    End If
                    If nameRetsu <> 0 Then
                        wsOutput.Cells(outputGyou, nameRetsu).Value = .GetFile(objFile).Name
                    End If
                    If typeRetsu <> 0 Then
                        wsOutput.Cells(outputGyou, typeRetsu).Value = "File"
                    End If
                    If sizeRetsu <> 0 Then
                        wsOutput.Cells(outputGyou, sizeRetsu).Value = .GetFile(objFile).Size
                    End If
                    If lastmodifyRetsu <> 0 Then
                        wsOutput.Cells(outputGyou, lastmodifyRetsu).Value = .GetFile(objFile).DateLastModified
                    End If
                    If kaisouStratRetsu <> 0 Then
                        wsOutput.Cells(outputGyou, fileRetsu).Value = .GetFile(objFile).Name
                    End If

                    If maxDataRetsu < fileRetsu Then  ' 最大データ列の更新
                        maxDataRetsu = fileRetsu
                    End If

                Else
                    ' 該当していない場合は、何もしない
                End If

            Else  ' ファイル種別の指定が無い場合
                outputGyou = outputGyou + 1
                maxDataGyou = outputGyou

                If ThisWorkbook.Worksheets("階層図作成").CheckChangeColor.Value = True Then  ' フォルダとファイルで色分けする場合
                    wsOutput.Range(Cells(outputGyou, 1), Cells(outputGyou, maxRetsu)).Interior.Color = 9961471
                End If

                If pathRetsu <> 0 Then
                    wsOutput.Cells(outputGyou, pathRetsu).Value = .GetFile(objFile).Path
                End If
                If nameRetsu <> 0 Then
                    wsOutput.Cells(outputGyou, nameRetsu).Value = .GetFile(objFile).Name
                End If
                If typeRetsu <> 0 Then
                    wsOutput.Cells(outputGyou, typeRetsu).Value = "File"
                End If
                If sizeRetsu <> 0 Then
                    wsOutput.Cells(outputGyou, sizeRetsu).Value = .GetFile(objFile).Size
                End If
                If lastmodifyRetsu <> 0 Then
                    wsOutput.Cells(outputGyou, lastmodifyRetsu).Value = .GetFile(objFile).DateLastModified
                End If
                If kaisouStratRetsu <> 0 Then
                    wsOutput.Cells(outputGyou, fileRetsu).Value = .GetFile(objFile).Name
                End If

                If maxDataRetsu < fileRetsu Then  ' 最大データ列の更新
                    maxDataRetsu = fileRetsu
                End If

            End If

        Next objFile

        If ThisWorkbook.Worksheets("階層図作成").CheckSearchSubFolder.Value = True Then  ' サブフォルダも検索する場合
            ' 再帰処理でサブフォルダのデータを出力する
            For Each objSubFolder In objFolder.SubFolders

                outputGyou = outputGyou + 1
                maxDataGyou = outputGyou

                Call FileFolderSearch(objSubFolder.Path, folderRetsu + 1, fileRetsu + 1)  ' ここで自分自身を呼び出す再帰処理

            Next objSubFolder
        Else
            '　何もしない
        End If

    End With

End Sub


Sub CheckInput()  ' 入力内容のチェック

    Dim outputRetsuShitei() As Long        ' 出力列の指定内容を格納する配列
    Dim i As Long
    Dim j As Long
    Dim bol1 As Boolean

    If objFSO.FolderExists(wsKaisouzuSakusei.Cells(4, 2).Value) = False Then
        MsgBox "指定されたフォルダは存在しません"
        End
    Else
        strStartPath = wsKaisouzuSakusei.Cells(4, 2).Value
        If Right(strStartPath, 1) <> "\" Then  ' パスの最後に￥が無い場合は、￥を付け足す
            strStartPath = strStartPath & "\"
            wsKaisouzuSakusei.Cells(4, 2).Value = wsKaisouzuSakusei.Cells(4, 2).Value & "\"
        End If
    End If

    Erase outputRetsuShitei
    ReDim Preserve outputRetsuShitei(1)
    For i = 1 To 6
        If wsKaisouzuSakusei.Cells(i + 6, 4).Value <> "" Then
            outputRetsuShitei(UBound(outputRetsuShitei)) = wsKaisouzuSakusei.Cells(i + 6, 4).Value  ' 指定された出力列を配列に格納
            ReDim Preserve outputRetsuShitei(UBound(outputRetsuShitei) + 1)
        End If
    Next i

    If outputRetsuShitei(1) = 0 Then
        MsgBox "出力内容の指定が１つもされていません"
        End
    End If

    For i = 1 To UBound(outputRetsuShitei) - 1
        For j = 1 To UBound(outputRetsuShitei) - 1
            If outputRetsuShitei(i) = outputRetsuShitei(j) And i <> j And outputRetsuShitei(i) <> 0 Then
            ' 出力列の指定に重複がある場合
                MsgBox "出力列の指定に重複があります"
                End
            End If
        Next j
    Next i

    ' 「階層図作成開始」の出力指定列が最も大きいことのチェック
    If wsKaisouzuSakusei.Cells(12, 4).Value <> "" Then
        For i = 7 To 11
            If wsKaisouzuSakusei.Cells(i, 4).Value > wsKaisouzuSakusei.Cells(12, 4).Value Then
                MsgBox "「階層図作成開始」の出力指定列は他の指定列よりも大きい列番号にしてください"
                End
            End If
        Next i
    End If

    With ThisWorkbook.Worksheets("階層図作成") ' 出力するファイル種別の指定をチェック

        If .CheckSelectFileType.Value = True Then
            Erase selectFileType
            ReDim Preserve selectFileType(1)
            If .CheckXlsx.Value = True Then
                selectFileType(UBound(selectFileType)) = ".xlsx"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckXlsm.Value = True Then
                selectFileType(UBound(selectFileType)) = ".xlsm"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckXls.Value = True Then
                selectFileType(UBound(selectFileType)) = ".xls"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckDocx.Value = True Then
                selectFileType(UBound(selectFileType)) = ".docx"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckDoc.Value = True Then
                selectFileType(UBound(selectFileType)) = ".doc"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckTxt.Value = True Then
                selectFileType(UBound(selectFileType)) = ".txt"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckPdf.Value = True Then
                selectFileType(UBound(selectFileType)) = ".pdf"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckJpg.Value = True Then
                selectFileType(UBound(selectFileType)) = ".jpg"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If
            If .CheckPng.Value = True Then
                selectFileType(UBound(selectFileType)) = ".png"
                ReDim Preserve selectFileType(UBound(selectFileType) + 1)
            End If

            If selectFileType(1) = "" Then
                MsgBox "「出力するファイル種別を指定する」のチェックが入っていますが、ファイル種別が１つも選択されていません"
                End
            End If
        End If

    End With

End Sub


Sub SelectFolder()  ' フォルダを選択するダイアログを開く

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Cells(4, 2).Value = .SelectedItems(1) & "\"
        Else
            MsgBox "キャンセルされました"
        End If
    End With

End Sub