Directories and Sub-Directories

[bromy2004]

Hi,

i have found a macro online which works almost perfectly

Option Explicit
Private cnt As Long
Private arfiles
Private level As Long
Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean
    arfiles = Array()
    cnt = -1
    level = 1
    sFolder = "Z:\"
    ReDim arfiles(2, 0)
    If sFolder <> "" Then
        SelectFiles sFolder
        Application.DisplayAlerts = False
        On Error Resume Next
        Worksheets("Files").Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
        Worksheets.Add.Name = "Files"
        With ActiveSheet
            For i = LBound(arfiles, 2) To UBound(arfiles, 2)
                If arfiles(0, i) = "" Then
                    If fOutline Then
                        Rows(iStart + 1 & ":" & iEnd).Rows.Group
                    End If
                    With .Cells(i + 1, arfiles(2, i))
                        .Value = arfiles(1, i)
                        .Font.Bold = True
                    End With
                    iStart = i + 1
                    iEnd = iStart
                    fOutline = False
                Else
                    .Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
                                    Address:=arfiles(0, i), _
                                    TextToDisplay:=arfiles(1, i)
                    iEnd = iEnd + 1
                    fOutline = True
                End If
            Next
            .Columns("A:Z").ColumnWidth = 5
        End With
    End If
    'just in case there is another set to group
    If fOutline Then
        Rows(iStart + 1 & ":" & iEnd).Rows.Group
    End If
    Columns("A:Z").ColumnWidth = 5
    ActiveSheet.Outline.ShowLevels RowLevels:=1
    ActiveWindow.DisplayGridlines = False
End Sub
'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath
    If FSO Is Nothing Then
        Set FSO = CreateObject("Scripting.FileSystemObject")
    End If
    If sPath = "" Then
        sPath = CurDir
    End If
    arPath = Split(sPath, "\")
    cnt = cnt + 1
    ReDim Preserve arfiles(2, cnt)
    arfiles(0, cnt) = ""
    arfiles(1, cnt) = arPath(level - 1)
    arfiles(2, cnt) = level
    Set oFolder = FSO.GetFolder(sPath)
    Set oFiles = oFolder.Files
    For Each oFile In oFiles
        cnt = cnt + 1
        ReDim Preserve arfiles(2, cnt)
        arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
        arfiles(1, cnt) = oFile.Name
        arfiles(2, cnt) = level + 1
    Next oFile
    level = level + 1
    For Each oSubFolder In oFolder.Subfolders
        SelectFiles oSubFolder.Path
    Next
    level = level - 1
End Sub

the only problem is it doesn't keep the folder names properly

i.e. if i use Z:\ as the input, the folder structure/Macro is absolutely perfect.

Excel Workbook
	A	B	C	D	E
1	Z:\	*	*	*	*
2	*	Reports	*	*	*
3	*	*	Jet - Accounts	*	*
5	*	*	Jet - Managment	*	*
17	*	*	Jet - Purchasing	*	*
30	*	*	Jet - Sales And Marketing	*	*
55	*	*	*	Furniture & Print	*
61	*	*	Jet - Warehouse & Credit	*	*
70	*	Trial	*	*	*
80	*	*	*	*	*
Files

but if i use V:\Reports\ i get:

Excel Workbook
	A	B	C
1	V:	*	*
2	*	Reports	*
4	*	Reports	*
16	*	Reports	*
29	*	Reports	*
54	*	*	Jet - Sales And Marketing
60	*	Reports	*
Files

its supposed to be:

Excel Workbook
	A	B	C	D	E
1	V:	*	*	*	*
2	*	Reports	*	*	*
3	*	*	Jet - Accounts	*	*
5	*	*	Jet - Managment	*	*
17	*	*	Jet - Purchasing	*	*
30	*	*	Jet - Sales And Marketing	*	*
55	*	*	*	Furniture & Print	*
61	*	*	Jet - Warehouse & Credit	*	*
70	*	*	*	*	*
Files

Can anyone suggest a change i could make?? please?