Scribd
Upload
39 views3 pages

2

Uploaded by

jonalynmagsino23
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
39 views3 pages

2

Uploaded by

jonalynmagsino23
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 3

Sub sbListAllFolderDetails()

'Disable screen update


Application.ScreenUpdating = 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


Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Folder Details").Delete
Application.DisplayAlerts = True

'Add new Worksheet and name it as 'Folder Details'


With ThisWorkbook
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

'Main Header and its Fomat


With shtFldDetails.Range("A1")
.Value = "Folder and SubFolder Details"
.Font.Bold = True
.Font.Size = 12
.Interior.ThemeColor = xlThemeColorDark2
.Font.Size = 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").Font.Bold = True
End With

'Call Sub Procedure


'List all folders & subfolders
sbListAllFolders sRootFolderName

'Enable Screen Update


Application.ScreenUpdating = 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("Scripting.FileSystemObject")
Set oSourceFolder = oFSO.GetFolder(SourceFolder)

'Define Start Row


iLstRow = Sheets("Folder Details").Cells(Sheets("Folder Details").Rows.Count,
"A").End(xlUp).Row + 1

'Update Folder properties to Sheet


With Sheets("Folder Details")
.Range("A" & iLstRow) = oSourceFolder.Path
.Range("B" & iLstRow) = oSourceFolder.ShortPath
.Range("C" & iLstRow) = oSourceFolder.Name
.Range("D" & iLstRow) = oSourceFolder.ShortName
.Range("E" & iLstRow) = oSourceFolder.SubFolders.Count
.Range("F" & iLstRow) = oSourceFolder.Files.Count
.Range("G" & iLstRow) = oSourceFolder.Size
.Range("H" & iLstRow) = oSourceFolder.DateCreated
End With

'Loop through all Sub folders


For Each oSubFolder In oSourceFolder.SubFolders
sbListAllFolders oSubFolder.Path
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 = Application.FileDialog(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

You might also like