Help automating the macro

[dm28949]

This is the macro I have to list the folders and subfolders. I am trying to make some changes to it and automate a little more. I have a shared folder that has hundreds of folders and subfolders. For example: IM Department is the shared folder that has 100s of main folders like A/R, A/P, IT etc and these main folders have 100s of subfolders. How do I modify this code so that when I click on IM department folder it lists the properties of main folders upto 2 level? Right now when I click on IM department folder it only lists the main folders but what I need is up to 2 levels without having to click on individual folder to retrieve another level. I would appreciate any help on this and my apologies if my words here do not make sense. Thanks!

Option Explicit

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public fso, oFolder, Fil

Sub RecordRetention()
    Application.ScreenUpdating = False
    Dim newSheet As Worksheet
    Dim fldpath
    Dim fso As Object, j As Long, folder, SubFolders, SubFolder
    Dim LastRow As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choose the folder"
        .Show
    End With
    On Error Resume Next
    
    
    fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
    If fldpath = False Then
        MsgBox "Folder Not Selected"
        Exit Sub
    End If
    
    
    Set newSheet = ActiveSheet
    LastRow = FindLastRow(newSheet, "A")
    
    If LastRow = 1 Then
        newSheet.Cells(1, 1).Value = fldpath
        newSheet.Cells(2, 1).Value = "Path"
        newSheet.Cells(2, 2).Value = "Date Range"

        newSheet.Cells(2, 3).Value = "Size"
    Else
        newSheet.Cells(LastRow + 2, 1).Value = fldpath
        newSheet.Cells(LastRow + 3, 1).Value = "Path"
        newSheet.Cells(LastRow + 3, 2).Value = "Date Range"

        newSheet.Cells(LastRow + 3, 3).Value = "Size"
    End If
    
    
    LastRow = FindLastRow(newSheet, "A")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(fldpath)
    Set SubFolders = folder.SubFolders
    j = LastRow + 1
    For Each SubFolder In SubFolders
        Cells(j, 1).Value = SubFolder.Path
        Cells(j, 2).Value = Format(SubFolder.DateCreated, "MM/DD/YYYY") & " - " & Format(SubFolder.DateLastModified, "MM/DD/YYYY")
        
        Cells(j, 3).Value = Format(SubFolder.Size / 1024 / 1024, "0.0 \MB")
        j = j + 1
    Next SubFolder
    Set fso = Nothing
    Range("a" & LastRow - 1).Font.Size = 11
    ActiveWindow.DisplayGridlines = True
    Range("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 11
   ' Range("a" & LastRow & ":d" & LastRow).Interior.Color = vbCyan
    Columns("A:H").AutoFit
    Application.ScreenUpdating = True
End Sub

Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
    FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function