File info pull from sub folders only 2-3 levels deep - vba

Question

I currently have a code that will allow the user to pick a folder and then the code will pull the file information for the files in that folder but not for any files in sub folders. I have 7 levels of subfolders containing about 140,000 files. I was wondering if there is a way for me to pull only pull the info of files in subfolder level 2-3 not solely 1 and not from all 7 levels. Thank you for your help.
I don't think the "pasting formula in column 3" section will be relevant for this problem.
The sections that probably matter are "Picking a folder" and "Running through each file in the selected folder"
Sub Compile3()
Dim oShell As Object
Dim oFile As Object
Dim oFldr As Object
Dim lRow As Long
Dim iCol As Integer
Dim vArray As Variant
vArray = Array(10, 0, 1, 156, 2, 4, 144, 146, 183, 185)
Set oShell = CreateObject("Shell.Application")
Dim iRow As Long
iRow = Cells.find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
lRow = iRow
'----------------------Picking a folder-------------------------------------
With Application.FileDialog(msoFileDialogFolderPicker)
.title = "Select the Folder..."
If .Show Then
Set oFldr = oShell.Namespace(.SelectedItems(1))
With oFldr
'Don't show update on the screen until the macro is finished
Application.EnableEvents = False
'---------------Column header information-----------------------------------
For iCol = LBound(vArray) To UBound(vArray)
If lRow = 2 Then
Cells(lRow, iCol + 4) = .getdetailsof(.items, vArray(iCol))
Else
Cells(lRow, iCol + 4) = "..."
End If
Next iCol
'---------------Running through each file in the selected folder------------
For Each oFile In .items
lRow = lRow + 1
For iCol = LBound(vArray) To UBound(vArray)
Cells(lRow, iCol + 4) = .getdetailsof(oFile, vArray(iCol))
Next iCol
' ---------------Pasting formula in column 3 -----------------------------
If lRow < 4 Then
Cells(lRow, 3).Formula = "=IFERROR(VLOOKUP(D3,$A$3:$B$10,2,FALSE),""User Not Found"")"
Else
Cells((lRow - 1), 3).Copy
Cells(lRow, 3).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells(lRow, 3).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
'------------------------------------------------------------------------------
Next oFile
End With
End If
Application.EnableEvents = True
End With
End Sub

Answer 1

I modified your code to work with arrays and use a recursive function to return the folder file information.
Sub ProcessFolder()
Dim FolderPath As String
Dim results As Variant
Dim Target As Range
FolderPath = getFileDialogFolder
If Len(FolderPath) = 0 Then Exit Sub
getFolderItems FolderPath, results
CompactResults results
With Worksheets("Sheet1")
.Range("C3", .Range("I" & Rows.Count).End(xlUp)).ClearContents
Set Target = .Range("C3")
Set Target = Target.EntireRow.Cells(1, 4)
Target.Resize(UBound(results), UBound(results, 2)).Value = results
Target.Offset(1, -1).Resize(UBound(results) - 1).Formula = "=IFERROR(VLOOKUP(D3,$A$3:$B$10,2,FALSE),""User Not Found"")"
End With
End Sub
Sub CompactResults(ByRef results As Variant)
Dim data As Variant
Dim x As Long, x1 As Long, y As Long, y1 As Long
ReDim data(1 To UBound(results) + 1, 1 To UBound(results(0)) + 1)
For x = LBound(results) To UBound(results)
x1 = x1 + 1
y1 = 0
For y = LBound(results(x)) To UBound(results(x))
y1 = y1 + 1
data(x1, y1) = results(x)(y)
Next
Next
results = data
End Sub
Function getFileDialogFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the Folder..."
.AllowMultiSelect = False
If .Show Then
getFileDialogFolder = .SelectedItems(1)
End If
End With
End Function
Sub getFolderItems(FolderPath As String, ByRef results As Variant, Optional MaxLevels As Long = 1, Optional oShell As Object, Optional Level As Long)
Dim oFile As Object, oFldr As Object
If oShell Is Nothing Then
ReDim results(0)
Set oShell = CreateObject("Shell.Application")
End If
If Not IsEmpty(results(UBound(results))) Then ReDim Preserve results(UBound(results) + 1)
Set oFldr = oShell.Namespace(CStr(FolderPath))
results(UBound(results)) = getFolderFileDetailArray(oFldr.Self, oFldr)
results(UBound(results))(1) = oFldr.Self.Path
For Each oFile In oFldr.Items
ReDim Preserve results(UBound(results) + 1)
If oFldr.getDetailsOf(oFile, 2) = "File folder" Then
If Level < MaxLevels Then
getFolderItems oFile.Path, results, MaxLevels, oShell, Level + 1
End If
End If
results(UBound(results)) = getFolderFileDetailArray(oFile, oFldr)
Next oFile
End Sub
Function getFolderFileDetailArray(obj As Object, oFldr As Object) As Variant
Dim iCol As Integer
Dim vDetailSettings As Variant
vDetailSettings = Array(10, 0, 1, 156, 2, 4, 144, 146, 183, 185)
For iCol = LBound(vDetailSettings) To UBound(vDetailSettings)
vDetailSettings(iCol) = oFldr.getDetailsOf(obj, vDetailSettings(iCol))
Next iCol
getFolderFileDetailArray = vDetailSettings
End Function

Answer 2

The file system object can do this for you.
In this example, the code returns every subfolder on your C:\ drive.
' Returns every folder under the C:\.
Sub CrawlFolder()
Dim fso As FileSystemObject ' Access the Windows file system.
Dim folder As folder ' Used to loop over folders.
Set fso = New FileSystemObject
For Each folder In fso.GetFolder("C:\").SubFolders
Debug.Print folder.Name
Next
End Sub
To view the results make sure you've turned the Immediate window on (View >> Immediate Window).
To use the file system object you'll need to add a reference (Tools >> References >> Windows Script Host Object Model).
You can add a second For Each Loop to view the files:
' Returns every folder under the C:\.
Sub CrawlFolder()
Dim fso As FileSystemObject ' Access the Windows file system.
Dim folder As folder ' Used to loop over folders.
Dim file As file ' Used to loop over files.
Set fso = New FileSystemObject
For Each folder In fso.GetFolder("C:\").SubFolders
For Each file In folder.Files
Debug.Print file.Name
Next
Next
End Sub