Listing Folder names in excel 1

[xlbo]

Hi,
I know it's possible to loop thru folders on a netwrok and pick up all files within a folder. What I'd like to do is similar but......

I need to loop thru all folders on a server and list them all in a worksheet. The catch is this...I only want to list those that are a maximum of 4 levels down from the root ie
\\Yorkshire\Shared\Knowledge\GeoffB\Excel
I only want to see up to GeoffB

As an alternative, if this isn't possible, if the folder's FULL path can be shown instead of just the folder name, I can work with that ie

show:
Yorkshire\Shared\Knowledge\GeoffB\Excel
in the cell

I can then loop thru and delete those with 4 or more "\"

TIA Rgds
~Geoff~

 

[MadForIt]

Hi Geoff,

Think i've nearly cracked this. Unfortunately i have left the code at work. Will get back to you soon.

Rgds

 

[acron]

I have not fully tested the followin, but pending MadForIt's return, it might suffice. The main routine takes the inital path as an argument, and recursively goes through all folders and subfolders up to the 4th level.

Sub ListFolders(strPath As String)
Dim fso As Object, fldr As Object, subFldr As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fldr = fso.GetFolder(strPath)
    For Each subFldr In fldr.Subfolders
        ActiveCell.Offset(1, 0).Select
        Selection = subFldr.Path
        If UBound(Split(subFldr.Path, &quot;\&quot;, -1)) < 4 And _
                subFldr.Subfolders.Count > 0 Then ListFolders (subFldr.Path)
    Next
    Set subFldr = Nothing
    Set fldr = Nothing
    Set fso = Nothing
End Sub

Use somethjing like the following to call the routine :

Sub FolderListing()
    strPath = InputBox("Enter Path")
    If Len(strPath) = 0 Then Exit Sub
    ActiveCell = "Folders in " & strPath
    ListFolders (strPath)
End Sub

A.C

 

[xlbo]

Cheers for the responses - got it to work eventually using the following code:
Sub LoopFolders()
'Loops thru 4 levels of sub folders
'Application.ScreenUpdating = False

Dim fso As New FileSystemObject
Dim f As Folder, sf As Folder, ssf as folder, sssf as folder, ssssf as folder, path As String
'Initialize path.
path = "w:\"
'Get a reference to the Folder object.
Set f = fso.GetFolder(path)
'Iterate through subfolders.
r = 2
x = 0
On Error Resume Next
For Each sf In f.SubFolders
Range("A" & r).Value = sf.path
r = r + 1
x = x + 1
For Each ssf In sf.SubFolders
Range("A" & r).Value = ssf.path
r = r + 1
For Each sssf In ssf.SubFolders
Range("A" & r).Value = sssf.path
r = r + 1
For Each ssssf In sssf.SubFolders
Range("A" & r).Value = ssssf.path
r = r + 1

Next
Next
Next
Next
End Sub Rgds
~Geoff~

 

[MadForIt]

Hi, Thought i might as well post the code anyway.

Rgds.

Sub Folders()
Sheets("Sheet1&quot.Cells.ClearContents
Cells(2, 1) = "C:"
First = 2
Last = 2
For Level = 1 To 4
For j = First To Last
Path = Cells(j, 1)
FileName = Dir(Path & "\", 22)
Do Until FileName = ""
Result = GetAttr(Path & "\" & FileName) And vbDirectory
If Result <> 0 And FileName <> &quot;.&quot; And FileName <> &quot;..&quot; Then
Range(&quot;A65535&quot.End(xlUp).Offset(1, 0) = Path & &quot;\&quot; & FileName
End If
FileName = Dir
Loop
Next j
First = Last + 1
Last = Range(&quot;A65535&quot.End(xlUp).Row
Next Level
End Sub