get lists names folders & subfolders and count the files extensions

[tubrak]

hello

I search for macro to shows the folders names & subfolders names and count the files extensions

in column A it will bring the folders names and each folder contains subfolders as in column B it should bring it , each subfolders contains many files in differnt extensions pdf,avi,docx.... for instance the folder name RRT contains two subfolders name is JAN, DGH . subfolder JAN contain many files (pdf,jpj,docx)
and the same thing with DGH . should count how many in the subfolders . somtimes some folders contains many subfolders and somtimes there is no subfolder at all in the folder . with considerin when press cells in column A,B I can open it

FILES.xlsm
	A	B	C
1	folder name	subfolder name	extensions files counts
2	RRT	JAN	5 PDF
3			3 JPG
4			1 DOCX
5		DGH	2 PDF
6			1 XLS
7	RR	NO SUBFOLDER	3 XLS
8	UPLOAD	IMAGES	4 JPG
9			1 PNG
10	INVNO	NO SUBFOLDER	30 PDF
11	VIDEOS	NO SUBFOLDER	15 MP4
12		ACTION	3 AVI
13
14
1

 

[tubrak]

thanks very much for your solution and time

 

[gabito705]

Sure.

Had to change it up a bit on the setup for the original code.

Book1
	A	B	C	D	E	F
1	Folder	Ext	Count		Path:	C:\Users\ME\OneDrive\Desktop\Root
2	Root	txt	1
3	Root\RootSub1	txt	1
4	Root\RootSub2	xlsx	1
5		txt	2
6	Root\RootSub2\RootSubSub1	xlsx	1
Sheet3

Public Sub FileExtCount()
    On Error Resume Next
    Dim oFolder As Object, oSubfolder As Object, oFile As Object
    Dim TP As String, fExt As String
    Dim FSO As Object:          Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim SD As Object:           Set SD = CreateObject("Scripting.Dictionary")
    Dim AL As Object:           Set AL = CreateObject("System.Collections.ArrayList")
    Dim queue As Collection:    Set queue = New Collection
    Dim SkipNum As Integer:     SkipNum = 4
    Dim r As Range:             Set r = Range("A2")
    Dim path As String:         path = Range("F1").Value2
       
    queue.Add FSO.GetFolder(path)

    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
       
        TP = TRIMPATH(oFolder.path, SkipNum)
       
        For Each oFile In oFolder.Files
            fExt = Split(oFile.Name, ".")(1)
            If Not SD.exists(fExt) Then
                SD.Add fExt, 1
            Else
                SD(fExt) = SD(fExt) + 1
            End If
        Next oFile
       
        For j = 0 To SD.Count - 1
            If j = 0 Then
                AL.Add Join(Array(TP, SD.keys()(j), SD.items()(j)), "*")
            Else
                AL.Add Join(Array(vbNullString, SD.keys()(j), SD.items()(j)), "*")
            End If
        Next j
       
        SD.RemoveAll
    Loop

Set r = r.Resize(AL.Count)

With r
    .Value = Application.Transpose(AL.toArray)
    .TextToColumns , DataType:=xlDelimited, Other:=True, OtherChar:="*"
End With

End Sub

Function TRIMPATH(s As String, n As Integer)
Dim SP() As String:     SP = Split(s, "\")
Dim RS() As Variant:    ReDim RS(1 To UBound(SP) - n)
Dim Pos As Integer:     Pos = 1

For i = n + 1 To UBound(SP)
    RS(Pos) = SP(i)
    Pos = Pos + 1
Next i

TRIMPATH = Join(RS, "\")

End Function

And then you need to add a worksheet event handler like this.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range:     Set r = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

If Not Intersect(r, Target) Is Nothing And Target.Cells.Count = 1 Then
    Dim path As String: path = Range("F1").Value2
    path = Left(path, InStrRev(path, "\"))
    If Target.Value = vbNullString Then Set Target = Target.End(xlUp)
    Shell "explorer.exe " & path & Target.Value2, vbNormalFocus
End If
End Sub

Seems to be working the way it should testing it out on this end.

I was having a problem running the code of lrobbo314. So, if you are using office 2021 you can change this line:

            fExt = Split(oFile.Name, ".")(1)

For these lines:

            temp_arr = Split(oFile.Name, ".")
            fExt = temp_arr(UBound(temp_arr))

This is necessary if you have name of files with some dots in the middle.

 

[lrobbo314]

I was having a problem running the code of lrobbo314. So, if you are using office 2021 you can change this line:

            fExt = Split(oFile.Name, ".")(1)

For these lines:

            temp_arr = Split(oFile.Name, ".")
            fExt = temp_arr(UBound(temp_arr))

This is necessary if you have name of files with some dots in the middle.

I thought about that, but the OP never mentioned a problem. But yeah, good correction for posterity sake. ?