List folder names and count number of files in each folder

Question

I found code on YouTube.

1. It counts Excel files.
   How can it read all the extensions in a folder?

2. It counts one directory.
   How can it read the subfolders and count files in them as well?

3. It displays the count answer in a message box.
   How can it display the answer in Column B?

E.g. There are five subfolders and each contains files with different extensions.

The code should read all the subfolders and list the name of folder in Excel and also count and return the answer in front of each folder name.

Sub CountFiles()
    Dim strDir As String
    Dim fso As Object
    Dim objFiles As Object
    Dim obj As Object
    Dim lngFileCount As Long
       
    strDir = "E:\2022\"
   
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    Set objFiles = fso.GetFolder(strDir).Files
   
    lngFileCount = objFiles.count
   
    MsgBox lngFileCount     'Total number of files
   
   
    '***************************************************
    'NOTE: Ensure that the following code does not overwrite _
     anything in your workbook.
    'Active worksheet should be a blank worksheet
   
    For Each obj In objFiles
      ActiveSheet.Cells(Rows.count, "A").End(xlUp).Offset(1, 0) = obj.Name
    Next obj
   
    Set objFiles = Nothing
    Set fso = Nothing
    Set obj = Nothing
   
End Sub

Answer 1

List Subfolders

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, "B").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
   
    ' Inform.
    MsgBox "Folders listed.", vbInformation
   
End Sub