To Count number of files in each of folder and subfolder

Yesterday I have been provided with a wonderful code by @VBasic2008 that is working perfectly fine.

In a parent directory if there are 500 subfolders, the code lists down the names of each subfolder in excel sheet and also count number of files available in each subfolder and return the value in excel sheet as well and by this way I am able to verify which folders have how many files in it.

However, I request I need to add one more step in it which is difficult for me.

I have noticed that within each subfolders there are 3 to 4 more folders and the files are organized in these folders extension wise (see below screenshot). means in each subfolders there are (Zip) (Word) (PDF) (XML) etc.

Is there any possibility where the code can also read these folders which are in each subfolder and can return the answer like mentioned below

If the result is not possible the way i suggested above than any format will be okay. but the only requirement is that it can read the folder properties within each subfolder and can return result.

Sub ListSubfolders()

' Define constants.
Const FolderPath As String = "E:\2022\"
 
' Reference the folder.
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FolderPath) Then
    MsgBox "The folder """ & FolderPath & """ doesn't exist.", vbCritical
    Exit Sub
End If
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)

' Reference the first cell.
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range
Set fCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)

' Write the folder properties.
' If you don't want this, then out-comment it but also copy the line
' 'Set fCell = fCell.Offset(1)' to the bottom of the loop.
fCell.Value = fsoFolder.Name
fCell.Offset(, 1).Value = fsoFolder.Files.Count

' Write the subfolders' properties.
Dim fsoSubfolder As Object
For Each fsoSubfolder In fsoFolder.SubFolders
    Set fCell = fCell.Offset(1)
    fCell.Value = fsoSubfolder.Name
    fCell.Offset(, 1).Value = fsoSubfolder.Files.Count
Next fsoSubfolder
 
End Sub

This will be much appreciated.

I can not see the images that you put in your question, but you can do a recursive function to count all files in subfolders

In example bellow, in first cell of each subdirectory is put a number indicating the sublevel, then in column of that sublevel is the name and the total of files is in the next column.

Sub CountAllFiles()    
Const FolderPath As String = "E:\2022\"
 
' Reference the folder.
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(FolderPath) Then
    MsgBox "The folder """ & FolderPath & """ doesn't exist.", vbCritical
    Exit Sub
End If
Dim fsoFolder As Object: Set fsoFolder = fso.GetFolder(FolderPath)

' Reference the first cell.
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range
Set fCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)

' Write the folder properties.
' If you don't want this, then out-comment it but also copy the line
' 'Set fCell = fCell.Offset(1)' to the bottom of the loop.
fCell.Value = fsoFolder.Name
fCell.Offset(, 1).Value = fsoFolder.Files.Count

' Write the subfolders' properties.
Dim fsoSubfolder As Object
For Each fsoSubfolder In fsoFolder.SubFolders
    Set fCell = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1)
    fCell.Value = fsoSubfolder.Name
    fCell.Offset(, 1).Value = fsoSubfolder.Files.Count
    Call countFiles(ws, fCell.Row, fsoSubfolder)
Next fsoSubfolder
End Sub    

Sub countFiles(ByVal ws As Worksheet, ByVal pRow As Integer, ByVal pFsoSubfolder As Object)
Dim col As Integer
Dim totCol As Integer
Dim foundName As Boolean

For Each fsoSubfolder In pFsoSubfolder.SubFolders
    ' find subfolder name in columns
    totCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    foundName = False
    For col = 3 To totCol
        If ws.Cells(1, col).Value = fsoSubfolder.Name Then
            foundName = True
            Exit For
        End If
    Next col
    If Not foundName Then
        ws.Cells(1, col).Value = "'" & fsoSubfolder.Name
    End If
    ws.Cells(pRow, col).Value = "'" & fsoSubfolder.Files.Count
    Call countFiles(ws, pRow, fsoSubfolder)
Next fsoSubfolder
End Sub