Sub sbListAllFolderDetails()
'Disable screen update
[Link] = False
'Variable Declaration
Dim shtFldDetails As Worksheet
Dim sRootFolderName As String
'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 list of folders and Subfolders",
vbInformation, "Input Required!"
Exit Sub
End If
'Delete Sheet if it exists
[Link] = False
On Error Resume Next
[Link]("Folder Details").Delete
[Link] = True
'Add new Worksheet and name it as 'Folder Details'
With ThisWorkbook
Set shtFldDetails = .[Link](After:=.Sheets(.[Link]))
[Link] = "Folder Details"
End With
'Create object for sheet name
Set shtFldDetails = Sheets("Folder Details")
'Clear Sheet
[Link]
'Main Header and its Fomat
With [Link]("A1")
.Value = "Folder and SubFolder Details"
.[Link] = True
.[Link] = 12
.[Link] = xlThemeColorDark2
.[Link] = 14
.HorizontalAlignment = xlCenter
End With
With shtFldDetails
'Merge Header cells
.Range("A1:H1").Merge
'Create Headers
.Range("A2") = "Folder Path"
.Range("B2") = "Short Folder Path"
.Range("C2") = "Folder Name"
.Range("D2") = "Short Folder Name"
.Range("E2") = "Number of Subfolders"
.Range("F2") = "Number of Files"
.Range("G2") = "Folder Size"
.Range("H2") = "Folder Create Date"
.Range("A2:H2").[Link] = True
End With
'Call Sub Procedure
'List all folders & subfolders
sbListAllFolders sRootFolderName
'Enable Screen Update
[Link] = True
End Sub
Sub sbListAllFolders(ByVal SourceFolder As String)
'Variable Declaration
Dim oFSO As Object, oSourceFolder As Object, oSubFolder As Object
Dim iLstRow As Integer
'Create object to FileSystemObject
Set oFSO = CreateObject("[Link]")
Set oSourceFolder = [Link](SourceFolder)
'Define Start Row
iLstRow = Sheets("Folder Details").Cells(Sheets("Folder Details").[Link],
"A").End(xlUp).Row + 1
'Update Folder properties to Sheet
With Sheets("Folder Details")
.Range("A" & iLstRow) = [Link]
.Range("B" & iLstRow) = [Link]
.Range("C" & iLstRow) = [Link]
.Range("D" & iLstRow) = [Link]
.Range("E" & iLstRow) = [Link]
.Range("F" & iLstRow) = [Link]
.Range("G" & iLstRow) = [Link]
.Range("H" & iLstRow) = [Link]
End With
'Loop through all Sub folders
For Each oSubFolder In [Link]
sbListAllFolders [Link]
Next oSubFolder
'Autofit content in respective columns
Sheets("Folder Details").Columns("A:H").AutoFit
'Release Objects
Set oSubFolder = Nothing
Set oSourceFolder = Nothing
Set oFSO = Nothing
End Sub
Public Function sbBrowesFolder()
Dim FldrPicker As FileDialog
Dim myPath As String
'Browse Folder Path
Set FldrPicker = [Link](msoFileDialogFolderPicker)
With FldrPicker
.Title = "Browse Root Folder Path"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function
myPath = .SelectedItems(1)
End With
sbBrowesFolder = myPath
If myPath = vbNullString Then Exit Function
End Function
