過去資材の所在調査ツールとして。

機能

• 前回の出力結果をクリア。
• 対象フォルダ内のファイル名およびサブフォルダ名（サブフォルダ内のファイル名）を一覧化。
• 各ファイル、サブフォルダへのハイパーリンクを設定。

　※参考記事は こちら

シート建付け

• シート名
  資材リスト 取得
• シート構成
  • 対象フォルダ　　→　セル C3
  • リスト出力起点　→　セル C5
    ※対象フォルダパスが「G:\xxxx...」ではなく「\\hoge\fuga\xxx...」などのサーバ名から始まる場合は出力位置がズレる（バックスラッシュの数で列数を算出するため）
    

ソースコード

< Module1 >

• 共通設定

'＜ 命名規則 ＞
'定数：CONST_NAME
'変数：varName
'プロシージャ: ProcedureName

'＜ 共通設定 ＞
'シート名
Public Const SHEET_NAME_FOLDER_AND_FILE_LIST = "資材リスト 取得"
'オブジェクト
Public Const FILE_SYSTEM_OBJECT = "Scripting.FileSystemObject"
'区切り文字
Public Const DELIMITER_BS = "\"

• メイン処理

'***** 資材リスト 取得 *****
'◆メイン処理
Sub GetFolderAndFileList()

    '行数
    Const SEARCH_PATH_ROW = 3
    Const START_LIST_ROW = 5
    Const START_SUBFOLDER_ROW = 6
    '列数
    Const SEARCH_PATH_COL = 3
    Const START_LIST_COL = 3
    '終了メッセージ
    Const END_MESSAGE = "出力完了"
    
    
    '処理前アクション
    StartAction SHEET_NAME_FOLDER_AND_FILE_LIST, False
    
    
    'クリア処理
    ClearOldMaterialsList START_LIST_ROW, START_LIST_COL
    
    
    '対象フォルダパス 取得
    Dim targetFolder As String
    targetFolder = Cells(SEARCH_PATH_ROW, SEARCH_PATH_COL).Value
    
    
    '起点 出力
    ActiveSheet.Hyperlinks.Add _
        anchor:=Cells(START_LIST_ROW, START_LIST_COL), _
        Address:=targetFolder
    
    
    Dim fso As Object
    Dim folderObject As Object
    Set fso = CreateObject(FILE_SYSTEM_OBJECT)
    Set folderObject = fso.getfolder(targetFolder)
    
    
    'サブフォルダ 取得
    GetSubFolders folderObject, targetFolder, START_SUBFOLDER_ROW, START_LIST_COL
    
    
    'オブジェクト開放
    Set folderObject = Nothing
    Set fso = Nothing
    
    
    '処理後アクション
    EndAction SHEET_NAME_FOLDER_AND_FILE_LIST, END_MESSAGE


End Sub

• ファイル・サブフォルダ一覧化

'◆ファイル・サブフォルダ一覧化
Sub GetSubFolders(targetObj As Variant, ByVal targetFolder As String, targetRow As Long, targetCol As Long)


    Dim targetFile As Variant
    Dim fileLevel As Long
    
    
    'ファイル 一覧化
    For Each targetFile In targetObj.Files
        
        fileLevel = UBound(Split(Replace(targetFile.Path, targetFolder, ""), DELIMITER_BS))
        Cells(targetRow, targetCol + fileLevel) = targetFile.Name
        
        LineDraw targetRow, targetCol, fileLevel
        
        ActiveSheet.Hyperlinks.Add _
            anchor:=Cells(targetRow, targetCol + fileLevel), _
            Address:=targetFile.Path

        targetRow = targetRow + 1
    
    Next
    
    
    Dim targetSubFolder As Variant
    Dim subFolderLevel As Long
    
    
    'サブフォルダ 一覧化
    For Each targetSubFolder In targetObj.subfolders
        
        subFolderLevel = UBound(Split(Replace(targetSubFolder.Path, targetFolder, ""), DELIMITER_BS))
        Cells(targetRow, targetCol + subFolderLevel) = targetSubFolder.Name
        
        LineDraw targetRow, targetCol, subFolderLevel
        
        ActiveSheet.Hyperlinks.Add _
            anchor:=Cells(targetRow, targetCol + subFolderLevel), _
            Address:=targetSubFolder.Path
        
        targetRow = targetRow + 1
        
        '再帰呼出
        GetSubFolders targetSubFolder, targetFolder, targetRow, targetCol
    
    Next


End Sub

• 罫線描画処理

'◆罫線描画
Sub LineDraw(targetRow, targetCol, targetLevel)
    
    '縦線
    Const VERTICAL_LINE = "│"

    '描画処理
    Dim i As Long
    For i = targetCol + targetLevel - 1 To targetCol Step -1
        If i = targetCol + targetLevel - 1 Then
            Cells(targetRow, i) = ChrW(&H23BF)
        Else
            Cells(targetRow, i) = VERTICAL_LINE
        End If
        Cells(targetRow, i).HorizontalAlignment = xlCenter
    Next

End Sub

• クリア処理

'◆既存データ 削除
Sub ClearOldMaterialsList(ByVal startListRow As Long, ByVal startListCol As Long)
    
    '対象セルから”最終セル”までを削除
    Range( _
        Cells(startListRow, startListCol), _
        ActiveCell.SpecialCells(xlLastCell) _
    ).Clear

End Sub

< Module2 >

Option Explicit

'■ ■ ■　よく使う処理　■ ■ ■

'***** 処理前アクション *****
'機能：処理開始前にExcelの描画を止める（任意）
Sub StartAction(ByVal sheetName As String, Optional ByVal ScreenUpdateFlag As Boolean = True)

    ThisWorkbook.Activate
    
    '描画停止
    If ScreenUpdateFlag = False Then
        Application.ScreenUpdating = ScreenUpdateFlag
    End If
    
    '対象シート 有効化
    Worksheets(sheetName).Activate

End Sub


'***** 処理後アクション *****
'機能：① Excelの描画を再開させる。
'　　：② [Ctrl + HOME] を押下した位置にカーソルを移動させる。
'　　：③ 終了メッセージを表示させる。
Sub EndAction(ByVal sheetName As String, ByVal endMessage As String)

    ThisWorkbook.Activate
    
    '描画再開
    Application.ScreenUpdating = True
    
    '対象シート 有効化
    Sheets(sheetName).Activate
    
    'Ctrl + HOMEの位置にカーソル移動
    With ActiveWindow
        ActiveWindow.ActiveSheet.Cells(.SplitRow + 1, .SplitColumn + 1).Activate
    End With
    
    '終了メッセージ 表示
    MsgBox endMessage

End Sub

ソースコードの全量は こちら
※転記漏れがあるかもしれないので。