'********************************************************************************
'********************************************************************************
'*** This program reads all the folders and sub folders on a selected drive ***
'*** then puts them into an Excel Sheet and groups the folders into a ***
'*** collapsible group. ***
'*** ***
'*** Written By Paul Found 17th Febuary 2008 ***
'********************************************************************************
'********************************************************************************
'**********************************
'Declare FSO as a FileSystemObject
'**********************************
Public FSO As Scripting.FileSystemObject
Sub RunAll()
GetAllFolder
FormatPage
GroupFileNames
Range("A1").Select
End Sub
Sub GetAllFolder() 'Sub routine to get file names
'******************
'Declare Variables
'******************
Dim MainFolderName As String
Dim drv As Drives
Dim DriveName() As String
Dim arrCount As Integer
'*********************************************
'Sets the FileSystemObject and Drive variable
'*********************************************
Set FSO = New Scripting.FileSystemObject
Set drv = FSO.Drives
arrCount = 1
'*********************************
'Put all drive names into a array
'*********************************
For Each d In drv
ReDim Preserve DriveName(arrCount)
strText = d.DriveLetter & ":\"
DriveName(arrCount - 1) = strText
arrCount = arrCount + 1
Next d
'********************************************************
'Build the options into a text string for the input box
'********************************************************
For i = 0 To UBound(DriveName()) - 1
InputText = InputText & i & " - Drive: " & DriveName(i) & Chr(13)
Next i
MainFolderName = InputBox("Choose a Drive number from the list below." & Chr(13) & _
InputText, "Drive Number", 0)
'**************************************************
'Pass the drive name to the GetSubFolder procedure
'**************************************************
GetSubFolder DriveName(MainFolderName)
Set FSO = Nothing
End Sub
Sub GetSubFolder(MainFolderName As String)
'******************
'Declare Variables
'******************
Dim MainFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long
Set MainFolder = FSO.GetFolder(MainFolderName)
On Error Resume Next
'**********************************
'Find the next available empty row
'**********************************
r = Range("A65536").End(xlUp).Row + 1
'****************************
'Put the Source name in cell
'****************************
Cells(r, 1).Formula = MainFolderName
r = r + 1
'***************************************
'Run this procedure for each sub folder
'***************************************
For Each SubFolder In MainFolder.SubFolders
GetSubFolder SubFolder.Path
Next SubFolder
Columns("A:H").AutoFit
Set MainFolder = Nothing
End Sub
Sub FormatPage() 'Format the list of folders
Dim ColCount, UsedCol As Integer
'***************************************************************************************
'Split the folders and Sub Folders into diffrent coloumns using the \ as the delimeter
'***************************************************************************************
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True
Cells.EntireColumn.AutoFit
'*****************************************
'Counts the rows and columns of the table
'*****************************************
Range("A1").Select
ColCount = Selection.CurrentRegion.Columns.Count
RowCount = Selection.CurrentRegion.Rows.Count
'set the sheet to all white background
With Cells.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
'****************************
'Put a title and format text
'****************************
If ColCount > 7 Then
UsedCol = 7
With Range(Cells(1, 8), Cells(1, ColCount))
.Merge
With .Font
.Bold = True
.Size = 10
.Name = "Tahoma"
.ColorIndex = 0
End With
.Value = "Not Included In Grouping"
.HorizontalAlignment = xlLeft
.ColumnWidth = 12
End With
With Range(Cells(1, 8), Cells(RowCount, ColCount)).Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
Else
UsedCol = ColCount
End If
With Range(Cells(1, 1), Cells(1, UsedCol))
.Merge
With .Font
.Bold = True
.Size = 14
.Name = "Tahoma"
.ColorIndex = 2
End With
With .Interior
.ColorIndex = 5
.Pattern = xlSolid
End With
.Value = "Pauls File List"
.HorizontalAlignment = xlLeft
End With
With Range(Cells(1, 1), Cells(RowCount, UsedCol)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range(Cells(1, 1), Cells(RowCount, UsedCol)).Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
End Sub
Sub GroupFileNames() 'Group the folders into a collapsible table
Dim intRow, intCol As Integer
Dim GroupName As String
Dim StartRow As Integer
Set xls = ActiveWorkbook.Worksheets("Sheet1")
StartRow = 2
intRow = 2
intCol = 1
Do While WorksheetFunction.CountBlank(xls.Range(Cells(1, intCol), Cells(65536, intCol))) < 65536 And intCol <= 7
Do While xls.Range("A" & intRow) <> ""
GroupName = xls.Cells(StartRow, intCol)
If GroupName = "" Then GoTo PassGroup:
Do While xls.Cells(intRow, intCol) = GroupName
intRow = intRow + 1
Loop
If xls.Cells(intRow, intCol) <> GroupName Then
intRow = intRow - 1
End If
If intRow > StartRow Then
xls.Range(Cells(StartRow + 1, intCol), Cells(intRow, intCol)).Select
Selection.Rows.Group
End If
PassGroup:
intRow = intRow + 1
StartRow = intRow
Loop
StartRow = 2
intRow = 2
intCol = intCol + 1
Loop
Set xls = Nothing
Set StartRange = Nothing
End Sub