【サンプル付き】更新日時と共にフォルダーツリー作成

Option Explicit

'定数
Const SET_ROW = 2
Const SET_COL = 5
Const SETTIME_COL = 6
Const SUBFOL_COL = 7

'グローバル変数
Dim row As Long

Sub Foldertree_withTime()

    Application.ScreenUpdating = False

    Dim folder_Path As String
    Dim folder As String
    Dim SaveFile As Long
    
    Call DataClear_FolderTree
    
    ThisWorkbook.Worksheets("フォルダー構成").Activate
    
    MsgBox " フォルダーを選択してね( ｰ`дｰ´)ｷﾘｯ"
    
    With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = " フォルダーを選択"
        If .Show = True Then
            folder_Path = .SelectedItems(1)
        Else
            MsgBox "終了します(TдT)"
            Exit Sub
        End If
    End With
    
    Cells(SET_ROW, SETTIME_COL) = FileDateTime(folder_Path)
    folder = Mid(folder_Path, InStrRev(folder_Path, "\") + 1)
            
    Cells(SET_ROW, SET_COL) = folder
    Cells(SET_ROW, SET_COL).Interior.Color = RGB(255, 255, 153)
    
    row = 2
    
    Call Make_foldertree(folder, SET_COL, SUBFOL_COL)
    
    Cells.Font.Name = "Meiryo UI"
    
    Range("E:R").EntireColumn.AutoFit
    
    MsgBox "フォルダー構成抽出が完了しました(｀･ω･´)ゞ"

End Sub

Sub Make_foldertree(Path As String, fcol As Long, subfcol As Long)

    Dim buf As String
    Dim f As Object
    Dim folder As Object
    Dim filedate As String
    
    buf = Dir(Path & "\*.*")
    Do While buf <> ""
        row = row + 1
        Cells(row, fcol) = buf
        Cells(row, fcol).Interior.Color = RGB(204, 255, 255)
        
        Cells(row, fcol + 1) = FileDateTime(Path & "\" & buf)
        buf = Dir()
    Loop
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Path).SubFolders
            row = row + 1
            Cells(row, subfcol) = f.Name
            Cells(row, subfcol).Interior.Color = RGB(255, 255, 153)
            
            Cells(row, subfcol + 1) = f.DateLastModified
            
            Call Make_foldertree(f.Path, fcol + 2, subfcol + 2)
        Next f
    End With

End Sub

Sub DataClear_FolderTree()

        ThisWorkbook.Worksheets("フォルダー構成").Activate
        Range("E2:R1048576").Clear
        
End Sub