【VBA】フォルダとファイルをツリー表示にしてリンクも貼る

Excelでフォルダとファイルをツリー表示

指定したフォルダとファイルをツリー表示にしてExcelのワークシートに書き込み、リンクも貼ります。

ソースコード

Option Explicit

Private sh As Worksheet
Private rowIndex As Long

Private Const START_ROW As Integer = 4
Private Const START_COL As Integer = 2
Private Const TOOL_SH As String = "フォルダツリー"
Private Const TOP_PATH_ADDRESS As String = "D2"

'---------------------------------------------------------------------------------------------------
'【処 理 名】フォルダツリー
'【処理概要】フォルダツリーを取得し、リンクを生成する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub フォルダツリー取得()
    Dim path As String         '先頭フォルダパス
    Dim columnIndex As Long    'カラムインデックス
    
    ' ワークシートオブジェクト取得
    Set sh = ThisWorkbook.Worksheets(TOOL_SH)
    '先頭フォルダパス取得
    path = sh.Range(TOP_PATH_ADDRESS).Value
    
    If Not validation(path) Then
        Exit Sub
    End If
    
    rowIndex = START_ROW
    columnIndex = START_COL
    
    Call getFolderStructure(path, columnIndex)
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】ファイル一覧出力
'【処理概要】フォルダ・ファイル名を出力する
'【引    数】ByVal sTopPath As String     フォルダパス
'          ByVal columnIndex As Long    カラムインデックス
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub getFolderStructure(ByVal sTopPath As String, ByVal columnIndex As Long)
    ' ツール > 参照設定 > Microsoft Scripting Runtime
    Dim oFso As New FileSystemObject    'ファイルシステムオブジェクト
    Dim oTopDir As Folder               'フォルダオブジェクト
    Dim oDir As Folder                  'フォルダオブジェクト
    Dim oFile As File                   'ファイルオブジェクト
    Dim hypLink As Hyperlink            'ハイパーリンク
    
    ' フォルダオブジェクト取得
    Set oTopDir = oFso.GetFolder(sTopPath)

    'ハイパーリンク生成
    Set hypLink = sh.Hyperlinks.Add(Anchor:=sh.Cells(rowIndex, columnIndex), _
                                            Address:=sTopPath, _
                                            TextToDisplay:=oFso.GetFolder(sTopPath).Name)
    
    rowIndex = rowIndex + 1
    
    For Each oDir In oTopDir.SubFolders
        '再帰
        Call getFolderStructure(oDir.path, columnIndex + 1)
    Next
    
    'ディレクトリ直下のすべてのファイル
    For Each oFile In oFso.GetFolder(sTopPath).Files
        'ファイルごとの処理
        Set hypLink = sh.Hyperlinks.Add(Anchor:=sh.Cells(rowIndex, columnIndex + 1), _
                                            Address:=oFile.path, _
                                            TextToDisplay:=oFso.GetFileName(oFile.path))
        rowIndex = rowIndex + 1
    Next
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】入力チェック
'【処理概要】入力チェックを行う
'【引    数】ByVal path As String パス
'【返 却 値】True     エラーなし
'          False    エラーあり
'---------------------------------------------------------------------------------------------------
Private Function validation(ByVal path As String) As Boolean
    If path = "" Then
        MsgBox "先頭フォルダのパスを入力してください"
        GoTo LBL_ERROR
    End If
    
    If Dir(path, vbDirectory) = "" Then
        MsgBox "先頭"
        GoTo LBL_ERROR
    End If

    validation = True
    Exit Function
    
LBL_ERROR:
    validation = False
    Exit Function
End Function

2020/12/26:フォルダ名に「.」(ドット)が含まれていると、フォルダ名のドット以降が出力されないとご指摘いただいて、修正しました。
その代わり、先頭がドットで後に数字が続く場合には対応していません。

ダウンロード

6 COMMENTS

しがない会社員

使わせていただきました。
ス..ス…(゚Д゚(゚Д゚ノ(゚Д゚ノ)ノスゲー!!!
1個1個フォルダ開いてリンク探して貼って
階層もわかるようにが
一瞬で終わり感激しました。ありがとうございます。

返信する
Lin

こんにちは、まさに求めていたことが出来て大変ありがたく使わせていただいております。
1つ、フォルダ名にドットが含まれていると、以降のフォルダ名が消えてしまうのですが、回避できる方法がありましたらご教示いただけませんでしょうか?

返信する
misk

Linさんこんにちは!
フォルダにドットが入っているパターンは気が付きませんでした。
大丈夫なように修正済みです。

55~57行目
 変更前:GetBaseName(sTopPath))
 変更後:oFso.GetFolder(sTopPath).Name)

返信する
F@NKS

参考にさせていただきました。
ちなみにシェアポイント上のファイルを取得したいのですが、、、、
こちらのソースで簡単に改良できませんか?

返信する
misk

F@NKSさんコメントありがとうございます。

試していないのですが
シェアポイントをローカルに同期させれば
使えませんか?

返信する

F@NKS へ返信する コメントをキャンセル

メールアドレスが公開されることはありません。

CAPTCHA