Help automating the macro

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!

Code:

---

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

---

This will list out the Folder, Path, Date Range, Size, and Level. It shows the option for using Early binding as opposed to Late binding, as it uses the FileSystemObject from the Microsoft Scripting Runtime, which you can set by going to Tools, References in the VBE.

Code:

---

Option Explicit

Private FolderCount As Long

Private Const MAXSUBFOLDERS As Long = 2

Sub RecordRetention()

    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Early Binding - reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Dim FSO As Scripting.FileSystemObject
'    Dim ParentFolder As Scripting.Folder
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Late Binding - no reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim FSO As Object
    Dim ParentFolder As Object
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
    Dim FolderChoice As Variant
    Dim NewSheet As Worksheet
   
    FolderChoice = BrowseForFolder
    If FolderChoice = False Then Exit Sub
   
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Early Binding - reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Set FSO = New Scripting.FileSystemObject
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Late Binding - no reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set FSO = CreateObject("Scripting.FileSystemObject")
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
   
    Set ParentFolder = FSO.GetFolder(FolderChoice)

    Set NewSheet = ActiveSheet ' ThisWorkbook.Worksheets.Add
    If WorksheetFunction.CountA(NewSheet.Cells) = 0 Then
        NewSheet.Range("A1").Resize(1, 5).Value = Array("Folder", "Path", "Date Range", "Size", "Level")
    End If
    FolderCount = UBound(Split(ParentFolder.Path, "\"))
   
    Call ListFolderDetails(ParentFolder, NewSheet, 1)
    NewSheet.Cells.Font.Size = 11
    NewSheet.Cells.EntireColumn.AutoFit
   
End Sub


Sub ListFolderDetails(ByVal Folder As Object, ByVal TargetSheet As Worksheet, Optional ByVal Level As Long = 1)
'If using Early Binding, use "ByVal Folder As Scripting.Folder" instead of "ByVal Folder As Object"

    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Early Binding - reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Dim SubFolder As Scripting.Folder
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Late Binding - no reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim SubFolder As Object
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
        Dim SheetRow As Long
   
    If (UBound(Split(Folder.Path, "\")) - FolderCount) > MAXSUBFOLDERS Then Exit Sub
   
    SheetRow = TargetSheet.Cells.Find(What:="*", After:=TargetSheet.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    TargetSheet.Cells(SheetRow, 1).Value = Folder.Name
    TargetSheet.Cells(SheetRow, 2).Value = Folder.Path
    TargetSheet.Cells(SheetRow, 3).Value = Format(Folder.DateCreated, "yyyy") & " - " & Format(Folder.DateLastModified, "yyyy")
    TargetSheet.Cells(SheetRow, 4).Value = Format(Folder.Size / 1024 / 1024, "#,##0.0 \MB")
    TargetSheet.Cells(SheetRow, 5).Value = Level
   
    For Each SubFolder In Folder.SubFolders
        Call ListFolderDetails(SubFolder, TargetSheet, UBound(Split(Folder.Path, "\")) - FolderCount + 2)
    Next SubFolder
   
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    '
    'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
    '
    'Function purpose:  To Browser for a user selected folder.
    'If the "OpenAt" path is provided, open the browser at that directory
    'NOTE:  If invalid, it will open at the Desktop level
   
    Dim ShellApp As Object
   
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
   
    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
   
    'Destroy the Shell Application
    Set ShellApp = Nothing
   
    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
   
    Exit Function
   
Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
   
End Function

---

HTH

@Zack Barresee Thank you so much. This is exactly what I wanted. However, it gives a runtime error when I run the code on the main folders that certain users do not have access to. Is it possible to skip the unaccessible subfolders? Like preventing the program from crashing when it bumps into unaccessbile subfolders?

You could try some error handling. Change the ListFolderDetails routine for this:

Code:

---

Sub ListFolderDetails(ByVal Folder As Object, ByVal TargetSheet As Worksheet, Optional ByVal Level As Long = 1)
'If using Early Binding, use "ByVal Folder As Scripting.Folder" instead of "ByVal Folder As Object"

    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Early Binding - reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Dim SubFolder As Scripting.Folder
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Late Binding - no reference set
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim SubFolder As Object
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
   
        Dim SheetRow As Long
   
    If (UBound(Split(Folder.Path, "\")) - FolderCount) > MAXSUBFOLDERS Then Exit Sub
   
    SheetRow = TargetSheet.Cells.Find(What:="*", After:=TargetSheet.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
   
    On Error GoTo Continue
    TargetSheet.Cells(SheetRow, 1).Value = Folder.Name
    TargetSheet.Cells(SheetRow, 2).Value = Folder.Path
    TargetSheet.Cells(SheetRow, 5).Value = Level
    TargetSheet.Cells(SheetRow, 3).Value = Format(Folder.DateCreated, "yyyy") & " - " & Format(Folder.DateLastModified, "yyyy")
    TargetSheet.Cells(SheetRow, 4).Value = Format(Folder.Size / 1024 / 1024, "#,##0.0 \MB")

Continue:
    On Error GoTo 0
    For Each SubFolder In Folder.SubFolders
        Call ListFolderDetails(SubFolder, TargetSheet, UBound(Split(Folder.Path, "\")) - FolderCount + 2)
    Next SubFolder
   
End Sub

---

I'm not able to test this code at the moment.

Thank you for your help. This script helped me and my coworkers save so much time!

I:\Systems\Presentations (ADM130)\R3
I:\Systems\Presentations (ADM130)\Customer

This is the reult of the above macro. I am trying to retrieve "ADM130" and put it in a seperate column and "Presentations" in a seperate one. How do I do this?