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
'Disable visual updates
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
'Browse Root Folder
sRootFolderName = sbBrowesFolder & "\"
'If path is not available, it display message and exit from the procedure
If sRootFolderName = "\" Then
MsgBox "Please select folder to find and list its contents.", vbInformation, "Input Required!"
Exit Sub
End If
'change sheet and range names
' to match your workbook
strPath = sRootFolderName
Set wbLinks = ThisWorkbook
strMsg = "Could not start the list"
'Delete Sheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
wbLinks.Sheets("Folder Details").Delete
Application.DisplayAlerts = True
'Add new Worksheet and name it as 'Folder Details'
With wbLinks
Set shtFldDetails = .Sheets.Add(After:=.Sheets(.Sheets.Count))
shtFldDetails.Name = "Folder Details"
End With
'Create object for sheet name
Set shtFldDetails = Sheets("Folder Details")
'Clear Sheet
shtFldDetails.Cells.Clear
Set wsZip = shtFldDetails
lRow = 4 'leave rows for heading
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
'Browse Folder Path
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
