Option Explicit
Sub ListAllFoldersForSubFolders()
Dim shtFldDetails As Worksheet
Dim fso As Object
Dim fldr As Object
Dim fldrSF As Object
Dim ofiles As Object
Dim wb As Workbook
Dim wbLinks As Workbook
Dim strPath As String
Dim strMsg As String
Dim strFld As String
Dim lRow As Long
Dim wsZip As Worksheet
Application.Calculation = xlManual
Application.DisplayAlerts = True
Application.ScreenUpdating = False
On Error GoTo errHandler
Dim sRootFolderName As String
m_InitAfterRefresh.resetTableTracking
Sheet5.Unprotect
Range("File_List").Locked = True
m_FindColsandHide.HideColumns
sRootFolderName = sbBrowesFolder & "\"
If sRootFolderName = "\" Then
MsgBox "Please select folder to find and list its contents.", vbInformation, "Input Required!"
Exit Sub
End If
strPath = sRootFolderName
Set wbLinks = ThisWorkbook
strMsg = "Could not start the list"
Application.DisplayAlerts = False
On Error Resume Next
wbLinks.Sheets("Folder Details").Delete
Application.DisplayAlerts = True
With wbLinks
Set shtFldDetails = .Sheets.Add(After:=.Sheets(.Sheets.Count))
shtFldDetails.Name = "Folder Details"
End With
Set shtFldDetails = Sheets("Folder Details")
shtFldDetails.Cells.Clear
Set wsZip = shtFldDetails
lRow = 4
Set fso = _
CreateObject("Scripting.FileSystemObject")
Set fldrSF = fso.GetFolder(strPath)
strMsg = "Could not count folders"
If Not fldrSF Is Nothing Then
processFolder fldrSF, strPath, wsZip, lRow
Else
MsgBox "Could not find main folder"
GoTo exitHandler
End If
With wsZip
With .Cells(1, 1)
.value = "Subfolders - " & strPath
.Font.Bold = True
.Font.Size = 14
End With
With .Range("B3:C3")
.value = Array("Folder Path", "Files")
.Font.Bold = True
End With
.Columns("B:C").EntireColumn.AutoFit
End With
strMsg = "List has been created"
exitHandler:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox strMsg
Exit Sub
errHandler:
Resume exitHandler
End Sub
Function processFolder(fldr As Object, strPath As String, wsZip As Worksheet, lRow As Long)
If Not fldr Is Nothing Then
Dim ofiles As Files
Set ofiles = fldr.Files
With wsZip
.Cells(lRow, 2).value = strPath
.Cells(lRow, 3).value = ofiles.Count
End With
lRow = lRow + 1
On Error Resume Next
For Each fldr In fldr.SubFolders
processFolder fldr, strPath & fldr.Name & "\", wsZip, lRow
Next fldr
End If
End Function
Public Function sbBrowesFolder()
Dim FldrPicker As FileDialog
Dim MyPath As String
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Browse Root Folder Path"
.AllowMultiSelect = False
If InitPath <> "" Then
If Right$(InitPath, 1) <> "\" Then
InitPath = InitPath & "\"
End If
.InitialFileName = InitPath
Else
.InitialFileName = "C:\"
End If
If .Show <> -1 Then Exit Function
MyPath = .SelectedItems(1)
End With
sbBrowesFolder = MyPath
If MyPath = vbNullString Then Exit Function
End Function