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

 

[lrobbo314]

It's pretty easy using Power Query.

Book1
	A	B	C
1	Path	Extension	Count
2	F Drive\Desktop\	.accdb	3
3		.csv	1
4	F Drive\Desktop\Access\	.accdb	5
5	F Drive\Desktop\Documents\	.accdb	12
6		.xlsx	6
8	F Drive\Desktop\Documents\FOB\Index\Thumbnail\	.jpg	1
9	F Drive\Desktop\Documents\GPS Info\Index\Thumbnail\	.jpg	1
10	F Drive\Desktop\Documents\MyProject1\Index\Thumbnail\	.jpg	1
11	F Drive\Desktop\Documents\MyProject2\Index\Thumbnail\	.jpg	4
12	F Drive\Desktop\Documents\New Template\Index\Thumbnail\	.jpg	1
13	F Drive\Desktop\Excel\	.xlsx	13
14		.csv	10
15	F Drive\Desktop\Excel\New folder\	.xlsx	4
16	F Drive\Desktop\Excel\RXL\	.csv	10
17	F Drive\Desktop\New folder\	.jpg	3
18	F Drive\Desktop\New folder (2)\	.jpg	11
21		.csv	1
23	F Drive\Desktop\Python\	.py	5
24	F Drive\Desktop\Supercharge BI\	.xlsx	2
25		.accdb	1
Documents

let
    Source = Folder.Files("C:\YourPath"),
    Group = Table.Group(Source, {"Folder Path", "Extension"}, {{"Count", each Table.RowCount(_), Int64.Type}}),
    Extract = Table.TransformColumns(Group, {{"Folder Path", each Text.AfterDelimiter(_, "\", 3), type text}}),
    Index = Table.AddIndexColumn(Extract, "Index", 0, 1, Int64.Type),
    Format = Table.AddColumn(Index, "Path", each try if Extract[Folder Path]{[Index]}=Extract[Folder Path]{[Index]-1}  then "" else [Folder Path] otherwise [Folder Path]),
    Reorder = Table.ReorderColumns(Format,{"Folder Path", "Path", "Extension", "Count", "Index"}),
    RC = Table.RemoveColumns(Reorder,{"Folder Path", "Index"})
in
    RC

 

[tubrak]

as in your picture . it seems great. truly I thought to be by vba . so I don't used PQ . may you guide me where I put this,please?

let
    Source = Folder.Files("C:\YourPath"),
    Group = Table.Group(Source, {"Folder Path", "Extension"}, {{"Count", each Table.RowCount(_), Int64.Type}}),
    Extract = Table.TransformColumns(Group, {{"Folder Path", each Text.AfterDelimiter(_, "\", 3), type text}}),
    Index = Table.AddIndexColumn(Extract, "Index", 0, 1, Int64.Type),
    Format = Table.AddColumn(Index, "Path", each try if Extract[Folder Path]{[Index]}=Extract[Folder Path]{[Index]-1}  then "" else [Folder Path] otherwise [Folder Path]),
    Reorder = Table.ReorderColumns(Format,{"Folder Path", "Path", "Extension", "Count", "Index"}),
    RC = Table.RemoveColumns(Reorder,{"Folder Path", "Index"})
in
    RC

 

[lrobbo314]

Sure thing.

First you would go to the ribbon and go to the 'Data' tab. There you will see a group where it says 'Get & Transform'. Click on the 'Get Data' button and under 'Other Sources', select 'Blank Query'. That will bring you into the Power Query editor.

From there you can select 'Advanced editor' and paste the code I provided.

You will need to edit the line that says 'Source' to reflect the actual directory you want to look at.

Also, you may need to adjust the integer value in this line.

Extract = Table.TransformColumns(Group, {{"Folder Path", each Text.AfterDelimiter(_, "\", 3), type text}}),

I did this as a way to get rid of some of the redundant parts of the folder path to closer match what you were going for in your original post. So, depending on how much of the path you want to cut off, you would just need to adjust that number '3'.

 

[lrobbo314]

Here is a VBA option if you would rather. Again, you may need to adjust the 'SkipNum' variable depending on how many levels deep your root path is.

Book1
	A	B	C
1	Folder	Ext	Count
2	Root	TXT	1
3	Root\RootSub1	TXT	1
4	Root\RootSub2	XLS	1
5		TXT	2
6	Root\RootSub2\RootSubSub1	XLS	1
Sheet3

Public Sub FileExtCount()
    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")
        
    queue.Add FSO.GetFolder("C:\Users\EBAAJ7O\OneDrive - US Customs and Border Protection\Desktop\Root")

    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

 

[tubrak]

wow ! two ways work both . for me I prefer vba . I have question about PQ if I add new files in directory . does update automatically or I have to update manually by right click and select refresh? . last thing how should can I open directory in column A when press any cell contain directory .

 

[lrobbo314]

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.

 

[lrobbo314]

And to answer your question... Yes, with the Power Query solution, you would need to refresh each time a new file is added. But, if a new file is added, you would also need to re-run the VBA code as well.

 

[tubrak]

fantastic ! you're legend

And to answer your question... Yes, with the Power Query solution, you would need to refresh each time a new file is added. But, if a new file is added, you would also need to re-run the VBA code as well.

but by vba can refresh automatically by put the procedure in workbook open_event . when file open . it will refresh automatically.

 

[lrobbo314]

Great! Glad I could help.

Yes, you could definitely call the subroutine in workbook_open or worksheet_activate and have it run automatically.