Help automating the macro

[dm28949]

This is the macro I have to list the folders and subfolders. I am trying to make some changes to it and automate a little more. I have a shared folder that has hundreds of folders and subfolders. For example: IM Department is the shared folder that has 100s of main folders like A/R, A/P, IT etc and these main folders have 100s of subfolders. How do I modify this code so that when I click on IM department folder it lists the properties of main folders upto 2 level? Right now when I click on IM department folder it only lists the main folders but what I need is up to 2 levels without having to click on individual folder to retrieve another level. I would appreciate any help on this and my apologies if my words here do not make sense. Thanks!




Option Explicit

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public fso, oFolder, Fil

Sub RecordRetention()
Application.ScreenUpdating = False
Dim newSheet As Worksheet
Dim fldpath
Dim fso As Object, j As Long, folder, SubFolders, SubFolder
Dim LastRow As Long

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next


fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If fldpath = False Then
MsgBox "Folder Not Selected"
Exit Sub
End If


Set newSheet = ActiveSheet
LastRow = FindLastRow(newSheet, "A")

If LastRow = 1 Then
newSheet.Cells(1, 1).Value = fldpath
newSheet.Cells(2, 1).Value = "Path"
newSheet.Cells(2, 2).Value = "Date Range"

newSheet.Cells(2, 3).Value = "Size"
Else
newSheet.Cells(LastRow + 2, 1).Value = fldpath
newSheet.Cells(LastRow + 3, 1).Value = "Path"
newSheet.Cells(LastRow + 3, 2).Value = "Date Range"

newSheet.Cells(LastRow + 3, 3).Value = "Size"
End If


LastRow = FindLastRow(newSheet, "A")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(fldpath)
Set SubFolders = folder.SubFolders
j = LastRow + 1
For Each SubFolder In SubFolders
Cells(j, 1).Value = SubFolder.Path
Cells(j, 2).Value = Format(SubFolder.DateCreated, "MM/DD/YYYY") & " - " & Format(SubFolder.DateLastModified, "MM/DD/YYYY")

Cells(j, 3).Value = Format(SubFolder.Size / 1024 / 1024, "0.0 \MB")
j = j + 1
Next SubFolder
Set fso = Nothing
Range("a" & LastRow - 1).Font.Size = 11
ActiveWindow.DisplayGridlines = True
Range("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 11
' Range("a" & LastRow & ":d" & LastRow).Interior.Color = vbCyan
Columns("A:H").AutoFit
Application.ScreenUpdating = True
End Sub

Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function

[Zack Barresse]

This will list out the Folder, Path, Date Range, Size, and Level. It shows the option for using Early binding as opposed to Late binding, as it uses the FileSystemObject from the Microsoft Scripting Runtime, which you can set by going to Tools, References in the VBE.


Option Explicit

Private FolderCount As Long

Private Const MAXSUBFOLDERS As Long = 2

Sub RecordRetention()

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Early Binding - reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Dim FSO As Scripting.FileSystemObject
' Dim ParentFolder As Scripting.Folder
'''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Late Binding - no reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FSO As Object
Dim ParentFolder As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim FolderChoice As Variant
Dim NewSheet As Worksheet

FolderChoice = BrowseForFolder
If FolderChoice = False Then Exit Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Early Binding - reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Set FSO = New Scripting.FileSystemObject
'''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Late Binding - no reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Set FSO = CreateObject("Scripting.FileSystemObject")
'''''''''''''''''''''''''''''''''''''''''''''''''''''


Set ParentFolder = FSO.GetFolder(FolderChoice)

Set NewSheet = ActiveSheet ' ThisWorkbook.Worksheets.Add
If WorksheetFunction.CountA(NewSheet.Cells) = 0 Then
NewSheet.Range("A1").Resize(1, 5).Value = Array("Folder", "Path", "Date Range", "Size", "Level")
End If
FolderCount = UBound(Split(ParentFolder.Path, "\"))

Call ListFolderDetails(ParentFolder, NewSheet, 1)
NewSheet.Cells.Font.Size = 11
NewSheet.Cells.EntireColumn.AutoFit

End Sub


Sub ListFolderDetails(ByVal Folder As Object, ByVal TargetSheet As Worksheet, Optional ByVal Level As Long = 1)
'If using Early Binding, use "ByVal Folder As Scripting.Folder" instead of "ByVal Folder As Object"

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Early Binding - reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Dim SubFolder As Scripting.Folder
'''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Late Binding - no reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim SubFolder As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim SheetRow As Long

If (UBound(Split(Folder.Path, "\")) - FolderCount) > MAXSUBFOLDERS Then Exit Sub

SheetRow = TargetSheet.Cells.Find(What:="*", After:=TargetSheet.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
TargetSheet.Cells(SheetRow, 1).Value = Folder.Name
TargetSheet.Cells(SheetRow, 2).Value = Folder.Path
TargetSheet.Cells(SheetRow, 3).Value = Format(Folder.DateCreated, "yyyy") & " - " & Format(Folder.DateLastModified, "yyyy")
TargetSheet.Cells(SheetRow, 4).Value = Format(Folder.Size / 1024 / 1024, "#,##0.0 \MB")
TargetSheet.Cells(SheetRow, 5).Value = Level

For Each SubFolder In Folder.SubFolders
Call ListFolderDetails(SubFolder, TargetSheet, UBound(Split(Folder.Path, "\")) - FolderCount + 2)
Next SubFolder

End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
'
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

HTH

[dm28949]

@Zack Barresee Thank you so much. This is exactly what I wanted. However, it gives a runtime error when I run the code on the main folders that certain users do not have access to. Is it possible to skip the unaccessible subfolders? Like preventing the program from crashing when it bumps into unaccessbile subfolders?

[Zack Barresse]

You could try some error handling. Change the ListFolderDetails routine for this:


Sub ListFolderDetails(ByVal Folder As Object, ByVal TargetSheet As Worksheet, Optional ByVal Level As Long = 1)
'If using Early Binding, use "ByVal Folder As Scripting.Folder" instead of "ByVal Folder As Object"

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Early Binding - reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Dim SubFolder As Scripting.Folder
'''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Late Binding - no reference set
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim SubFolder As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim SheetRow As Long

If (UBound(Split(Folder.Path, "\")) - FolderCount) > MAXSUBFOLDERS Then Exit Sub

SheetRow = TargetSheet.Cells.Find(What:="*", After:=TargetSheet.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

On Error GoTo Continue
TargetSheet.Cells(SheetRow, 1).Value = Folder.Name
TargetSheet.Cells(SheetRow, 2).Value = Folder.Path
TargetSheet.Cells(SheetRow, 5).Value = Level
TargetSheet.Cells(SheetRow, 3).Value = Format(Folder.DateCreated, "yyyy") & " - " & Format(Folder.DateLastModified, "yyyy")
TargetSheet.Cells(SheetRow, 4).Value = Format(Folder.Size / 1024 / 1024, "#,##0.0 \MB")

Continue:
On Error GoTo 0
For Each SubFolder In Folder.SubFolders
Call ListFolderDetails(SubFolder, TargetSheet, UBound(Split(Folder.Path, "\")) - FolderCount + 2)
Next SubFolder

End Sub

I'm not able to test this code at the moment.

[dm28949]

Thank you for your help. This script helped me and my coworkers save so much time!

[dm28949]

I:\Systems\Presentations (ADM130)\R3
I:\Systems\Presentations (ADM130)\Customer

This is the reult of the above macro. I am trying to retrieve "ADM130" and put it in a seperate column and "Presentations" in a seperate one. How do I do this?