Getting 2nd level of subfolders

[MM91]

Hi I have this code that I am using to list the names of subfolders in an array. However I need it to go one level deeper and get the subfolders of all these folders. What is the best way of doing this? Every method I use goes multiple levals deep and i am left with a list of all folders.

Dim i As Integer
Dim m As Integer
Dim serialnosf() as string
dim NumSF as integer

SerialNoFP = "C:\Users\mmi\Desktop\New folder\test"

Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(SerialNoFP)
Set sf = f.SUBFOLDERS
NumSF = f.SUBFOLDERS.Count
i = 1
ReDim SerialNoSF(1 To NumSF)
For Each f1 In sf
s = f1.Name
SerialNoSF(i) = s
i = i + 1
s = ""
Next


For m = 1 To NumSF
SerialNoUF.SerialNoBox.AddItem SerialNoSF(m)
Next

 

[JB2020]

There is a bunch of ways you could do it, but here is one:

Dim TempSheet As Worksheet
Dim F As Object, FSO As Object, SF As Object, RF As Object
Dim RowNumber As Long: RowNumber = 2
Dim SerialNoSF As Variant

Const SerialNoFP = "C:\Users\mmi\Desktop\New folder\test"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set RF = FSO.GetFolder(SerialNoFP)
Set TempSheet = ThisWorkbook.Sheets.Add
TempSheet.Range("A1:B1") = Array("Folder", "Subfolder")

For Each F In RF.Subfolders
    For Each SF In F.Subfolders
        TempSheet.Cells(RowNumber, 1).Resize(, 2) = Array(F.Name, SF.Name)
        RowNumber = RowNumber + 1
    Next SF
Next

SerialNoSF = TempSheet.UsedRange
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = True

 

[Fluff]

Another option

Dim i As Integer
Dim m As Integer
Dim serialnosf() As String
Dim NumSF As Integer

SerialNoFP = "C:\Users\mmi\Desktop\New folder\test"
ReDim serialnosf(1 To 10000)
Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(SerialNoFP)
Set sf = f.Subfolders
i = 1
For Each f1 In sf
   serialnosf(i) = f1.Name
   i = i + 1
   For Each f2 In f1.Subfolders
      serialnosf(i) = f2.Name
   i = i + 1
   Next
Next
ReDim Preserve serialnosf(1 To i - 1)

SerialNoUF.SerialNoBox.List = serialnosf

 

[MM91]

Another option

Dim i As Integer
Dim m As Integer
Dim serialnosf() As String
Dim NumSF As Integer

SerialNoFP = "C:\Users\mmi\Desktop\New folder\test"
ReDim serialnosf(1 To 10000)
Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(SerialNoFP)
Set sf = f.Subfolders
i = 1
For Each f1 In sf
   serialnosf(i) = f1.Name
   i = i + 1
   For Each f2 In f1.Subfolders
      serialnosf(i) = f2.Name
   i = i + 1
   Next
Next
ReDim Preserve serialnosf(1 To i - 1)

SerialNoUF.SerialNoBox.List = serialnosf

this worked great thank you so much!!

 

[Fluff]

Glad we could help & thanks for the feedback.