Macro to list folders and subfolders in excel based explorer with Properties

[JSH720]

I need a macro that , in excel, shows a folder name, its path, # folders underneath it and # files in each folder. Each sub folder would also be listed and properties included in the spreadsheet. Like I was clicking on properties of each folder and sub folder individually (which I don't want to do since there are thousands of them and thousands of sub folders). CMD way does not work since it is not in excel format and really difficult to parse.

Id like to be able to click on the folder of my choice to start this process instead of copying and pasting its path.

Thank YOu!

 

[Roderick_E]

That'll be $359.99 -- sorry couldn't resist but you're asking for a project.

 

[wideboydixon]

Paste this into a new module in the VBA editor:

Dim fso As Object
Dim nextRow As Long
Dim indent As Long
Dim newSheet As Worksheet
Public Sub ShowFolderDetails()

Set fso = CreateObject("Scripting.FileSystemObject")
Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count))
newSheet.Range("A1").Value = "Name"
newSheet.Range("B1").Value = "Path"
newSheet.Range("C1").Value = "Subfolders"
newSheet.Range("D1").Value = "Files"
newSheet.Range("1:1").Font.Bold = True

nextRow = 2
indent = 1

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Environ("USERPROFILE")
    .Show
    RecurseFolder .SelectedItems(1)
End With

newSheet.Columns("A:D").EntireColumn.AutoFit

End Sub
Private Sub RecurseFolder(folderPath As String)

Dim folderCount As Long
Dim fileCount As Long
Dim subFolder As Folder
Dim thisFolder As Folder

Set thisFolder = fso.GetFolder(folderPath)

folderCount = thisFolder.SubFolders.Count
fileCount = thisFolder.Files.Count
newSheet.Cells(nextRow, 1).Value = thisFolder.Name
newSheet.Cells(nextRow, 2).Value = folderPath
newSheet.Cells(nextRow, 3).Value = folderCount
newSheet.Cells(nextRow, 4).Value = fileCount
indent = indent + 1
nextRow = nextRow + 1
For Each subFolder In thisFolder.SubFolders
    RecurseFolder subFolder.Path
Next subFolder
indent = indent - 1

End Sub

Run the ShowFolderDetails macro.

WBD

 

[JSH720]

Paste this into a new module in the VBA editor:

Dim fso As Object
Dim nextRow As Long
Dim indent As Long
Dim newSheet As Worksheet
Public Sub ShowFolderDetails()

Set fso = CreateObject("Scripting.FileSystemObject")
Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count))
newSheet.Range("A1").Value = "Name"
newSheet.Range("B1").Value = "Path"
newSheet.Range("C1").Value = "Subfolders"
newSheet.Range("D1").Value = "Files"
newSheet.Range("1:1").Font.Bold = True

nextRow = 2
indent = 1

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Environ("USERPROFILE")
    .Show
    RecurseFolder .SelectedItems(1)
End With

newSheet.Columns("A:D").EntireColumn.AutoFit

End Sub
Private Sub RecurseFolder(folderPath As String)

Dim folderCount As Long
Dim fileCount As Long
Dim subFolder As Folder
Dim thisFolder As Folder

Set thisFolder = fso.GetFolder(folderPath)

folderCount = thisFolder.SubFolders.Count
fileCount = thisFolder.Files.Count
newSheet.Cells(nextRow, 1).Value = thisFolder.Name
newSheet.Cells(nextRow, 2).Value = folderPath
newSheet.Cells(nextRow, 3).Value = folderCount
newSheet.Cells(nextRow, 4).Value = fileCount
indent = indent + 1
nextRow = nextRow + 1
For Each subFolder In thisFolder.SubFolders
    RecurseFolder subFolder.Path
Next subFolder
indent = indent - 1

End Sub

Run the ShowFolderDetails macro.

WBD

I know I'm doing something wrong (novice at VBA) It errors out at "private Sub RecurseFoler (folderpath as string)

What am I missing?

 

[Roderick_E]

I tried it and had the same error, it's on the "...as Folder" dim. Perhaps WBD is using an add-in/extension we don't have loaded?

 

[Fluff]

I think you need to set a reference to "Microsoft Scripting RunTime"

 

[JSH720]

I think you need to set a reference to "Microsoft Scripting RunTime"

I dont know what I did , but it worked. Thanks!!!

 

[Roderick_E]

I think you need to set a reference to "Microsoft Scripting RunTime"

This is the reason I always try to find ways to code within the "vanilla" versions of Excel. Things break. But thanks for the pointer.

 

[wideboydixon]

Oops. Shoddy work there. I did create it with a reference to Microsoft Scripting Runtime and made a poor effort at removing that dependency. Tsk tsk. This will work (on Windows) without adding the reference:

Dim fso As Object
Dim nextRow As Long
Dim indent As Long
Dim newSheet As Worksheet
Public Sub ShowFolderDetails()

Set fso = CreateObject("Scripting.FileSystemObject")
Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count))
newSheet.Range("A1").Value = "Name"
newSheet.Range("B1").Value = "Path"
newSheet.Range("C1").Value = "Subfolders"
newSheet.Range("D1").Value = "Files"
newSheet.Range("1:1").Font.Bold = True

nextRow = 2
indent = 1

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Environ("USERPROFILE")
    .Show
    RecurseFolder .SelectedItems(1)
End With

newSheet.Columns("A:D").EntireColumn.AutoFit

End Sub
Private Sub RecurseFolder(folderPath As String)

Dim folderCount As Long
Dim fileCount As Long
Dim subFolder As Object
Dim thisFolder As Object

Set thisFolder = fso.GetFolder(folderPath)

folderCount = thisFolder.SubFolders.Count
fileCount = thisFolder.Files.Count
newSheet.Cells(nextRow, 1).Value = thisFolder.Name
newSheet.Cells(nextRow, 2).Value = folderPath
newSheet.Cells(nextRow, 3).Value = folderCount
newSheet.Cells(nextRow, 4).Value = fileCount
indent = indent + 1
nextRow = nextRow + 1
For Each subFolder In thisFolder.SubFolders
    RecurseFolder subFolder.Path
Next subFolder
indent = indent - 1

End Sub

On a Mac it's a no go ...

WBD

 

[JSH720]

Thank you so much!