count files extensions files for each month based on modified date

Hi,
I need fixing code to count how many files extensions for each month based on modified date in folders and subfolders and sub-subfolders
I put expected result should be in sheet1

Code:

---

Sub FindCountU()

Dim acs As Worksheet
Dim n As Workbook
Dim FolderName As String, Filename As String, ext$
Dim i As Integer, a$(), cnt&, j&, t&, ct&, f, fs
Dim dict As Object, ltst As Date, fin As Date
Set fs = CreateObject("Scripting.FileSystemObject")
Set dict = CreateObject("scripting.dictionary")
    FolderName = "C:\Users\ABB\Desktop\data" & "\"
    Filename = Dir(FolderName & "*.*")
    Do While Filename <> ""
        cnt = cnt + 1
        Filename = Dir()
    Loop


    ReDim a(1 To cnt, 1 To 2)
    Filename = Dir(FolderName & "*.*")
    Do While Filename <> ""
        i = i + 1
        Set f = fs.GetFile(FolderName & Filename)
        ext = Mid(Filename, InStr(1, Filename, ".") + 1)
        a(i, 1) = ext
        a(i, 2) = f.datelastmodified
        If Not dict.exists(ext) Then
            dict.Add ext, i
        End If
    Filename = Dir()
    Loop
    ct = 0
    ltst = #1/1/2001#
    fin = #1/1/2001#
    For j = 0 To dict.Count - 1
        For t = LBound(a) To UBound(a)
            If dict.keys()(j) = a(t, 1) Then
                ct = ct + 1
                If Format(a(t, 2), "mm/dd/yyyy") > Format(ltst, "mm/dd/yyyy") Then
                    ltst = Format(a(t, 2), "mm/dd/yyyy")
                    fin = Format(a(t, 2), "mm/dd/yyyy")
                End If
            End If
        Next t
        Sheets("SHEET1").Cells(j + 2, 1).Value = j + 1
        Sheets("SHEET1").Cells(j + 2, 2).Value = dict.keys()(j)
        Sheets("SHEET1").Cells(j + 2, 3).Value = ct
        Sheets("SHEET1").Cells(j + 2, 4).Value = UCase(Format(fin, "mmm"))
        ct = 0
        ltst = #1/1/2001#
        fin = #1/1/2001#
    Next j
End Sub

---

thanks

Your code needs to add a new row for each filetype/month pair? This means the dictionary must add a new item for each ext/month. You are only testing if ext exists, need to test for the pair. And if you want multi-year output, that means a third criteria to group by.

What is purpose of ltst and fin date variables?

Use InStrRev() instead of InStr() to locate last period in file name since there could be multiple periods (bt_21.10.1_64_win10.exe).
InStrRev(Filename, ".") + 1

Also don't see iteration through subfolders. Review http://allenbrowne.com/ser-59.html

This procedure needs significant re-working.

Maybe this might do what you want?

Code:

---

Sub CountFileExtensionsByMonth()
    Dim fso As Object, folder As Object, subFolder As Object, file As Object
    Dim wb As Workbook, ws As Worksheet, newWs As Worksheet
    Dim dict As Object, ext As String, monthYear As String
    Dim rowNum As Long
    Dim FolderPath As String
    ' Initialize FileSystemObject and Dictionary
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dict = CreateObject("Scripting.Dictionary")
    Set wb = ThisWorkbook ' This workbook
    ' Prompt the user for the folder path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder to process"
        .AllowMultiSelect = False
        If .Show = True Then
            FolderPath = .SelectedItems(1)
        Else
            MsgBox "Folder selection cancelled.", vbCritical
            Exit Sub
        End If
    End With
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    ' Create a new worksheet for the results
    Set newWs = wb.Sheets.Add
    newWs.Name = "File Extension Counts"
    ' Add headers to the worksheet
    newWs.Cells(1, 1).Value = "Month/Year"
    newWs.Cells(1, 2).Value = "Extension"
    newWs.Cells(1, 3).Value = "Count"
    rowNum = 2 ' Start writing data from row 2
    ' Recursive function to process folders and subfolders
    Sub ProcessFolder(ByRef folderPath As String)
        Dim currentFolder As Object, currentFile As Object, subFolderObj As Object
        Set currentFolder = fso.GetFolder(folderPath)
        ' Loop through each file in the current folder
        For Each currentFile In currentFolder.Files
            ext = LCase(fso.GetExtensionName(currentFile.Path)) ' Get and lowercase the extension
            monthYear = Format(currentFile.DateLastModified, "YYYY-MM") ' Get month and year
            If ext <> "" Then 'avoid counting files with no extension.
                If Not dict.exists(monthYear & "|" & ext) Then
                    dict.Add monthYear & "|" & ext, 1
                Else
                    dict(monthYear & "|" & ext) = dict(monthYear & "|" & ext) + 1
                End If
            End If
        Next currentFile
        ' Recursively process subfolders
        For Each subFolderObj In currentFolder.SubFolders
            ProcessFolder subFolderObj.Path
        Next subFolderObj
    End Sub
End Sub

---

Aussie, missing an End Sub and some code at end of first Sub.

You posted about 1 minute before I was going to post my version. Expect yours is better, once it's fixed.

Here it is anyway. For some reason I get a Desktop.ini file counted. Also, when the workbook was on the desktop and I used the Desktop as start folder, the Excel file was counted twice. I am guessing that would happen with any folder.

I set reference to MicrosoftScriptingRuntime library and used early binding.

Code:

---

Option Explicit


Public Function ListFileTypes(strPath As String, Optional strFileSpec As String, _    Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
'On Error GoTo Err_Handler
    'Purpose:  List the files in the path.
    'Arguments: strPath = the path to search.
    '          strFileSpec = "*.*" unless you specify differently.
    '          bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
    '          lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
    '              The list box must have its Row Source Type property set to Value List.
    'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
    Dim dicDirList As New Dictionary
    Dim varItem As Variant
    Dim r As Integer

    Call FillDir(dicDirList, strPath, strFileSpec, bIncludeSubfolders)
   
    'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
    If lst Is Nothing Then
        For Each varItem In dicDirList.keys
            Debug.Print varItem, dicDirList(varItem)
            Sheets("SHEET1").Cells(r + 2, 1) = r + 1
            Sheets("SHEET1").Cells(r + 2, 2) = Left(varItem, InStr(varItem, ":") - 1)
            Sheets("SHEET1").Cells(r + 2, 3) = colDirList(varItem)
            Sheets("SHEET1").Cells(r + 2, 4) = Mid(varItem, InStr(varItem, ":") + 1)
            r = r + 1
        Next
    Else
        For Each varItem In dicDirList
        lst.AddItem varItem
        Next
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Exit_Handler
End Function


Private Function FillDir(dicDirList As Dictionary, ByVal strFolder As String, strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    'Build up a list of files, and then add to this list, any additional folders
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant, oFile As Object, oFolder As folder, fso As New FileSystemObject
    Dim strKey As String

    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(strFolder)
    For Each oFile In oFolder.Files
        strKey = Mid(oFile.Name, InStrRev(oFile.Name, ".") + 1) & ":" & Format(oFile.DateLastModified, "yyyymmm")
        If Not dicDirList.exists(strKey) Then
            dicDirList.Add strKey, 1
        Else
            dicDirList.Item(strKey) = dicDirList.Item(strKey) + 1
        End If
    Next

    If bIncludeSubfolders Then
        'Build collection of additional subfolders.
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
        'Call function recursively for each subfolder.
        For Each vFolderName In colFolders
            Call FillDir(dicDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If
End Function


Public Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function

---

abdelfatttah, should always include Option Explicit at top of every module header. Automate this with VBA Editor > Tools > Options > check Require Variable Declaration.

See if this is how you wanted.

Code:

---

Sub test()
    Dim myDir$, x, myList()
    myDir = "C:\Users\ABB\Desktop\data"
    If Dir(myDir, vbDirectory) = "" Then MsgBox "Wrong folder path", vbCritical: Exit Sub
    x = SearchFiles(myDir, "*", 0, myList)
    If IsError(x) Then MsgBox "No file found", vbInformation: Exit Sub
    GetDetails myList
End Sub


Function SearchFiles(myDir$, myFileName$, n&, myList)
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.GetFolder(myDir).Files
        If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
        * (myFile.Name Like myFileName) Then
            If fso.GetExtensionName(myFile.Name) <> "" Then
                n = n + 1
                ReDim Preserve myList(1 To 3, 1 To n)
                myList(1, n) = myDir
                myList(2, n) = LCase$(fso.GetExtensionName(myFile.Name))
                myList(3, n) = Format$(myFile.DateLastModified, "yyyy - mm")
            End If
        End If
    Next
    For Each myFolder In fso.GetFolder(myDir).SubFolders
        SearchFiles = SearchFiles(myFolder.Path & "\", myFileName, n, myList)
    Next
    If n Then
        SearchFiles = myList
    Else
        SearchFiles = CVErr(2024)
    End If
End Function


Sub GetDetails(myList)
    Dim a, i&, ii&, s$, dic As Object, AL As Object, x As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set AL = CreateObject("System.Collections.ArrayList")
    Set x = AL.Clone
    For i = 1 To UBound(myList, 2)
        If Not AL.Contains(myList(3, i)) Then AL.Add myList(3, i)
        If Not x.Contains(myList(2, i)) Then x.Add myList(2, i)
        s = Join(Array(myList(2, i), myList(3, i)), Chr(2))
        dic(s) = dic(s) + 1
    Next
    AL.Sort: x.Sort
    ReDim a(1 To AL.Count + 1, 1 To x.Count + 1)
    a(1, 1) = "M - Y / EXT"
    For i = 0 To AL.Count - 1
        a(i + 2, 1) = AL(i)
    Next
    For i = 0 To x.Count - 1
        a(1, i + 2) = x(i)
    Next
    For i = 2 To UBound(a, 1)
        For ii = 2 To UBound(a, 2)
            a(i, ii) = dic(Join(Array(a(1, ii), a(i, 1)), Chr(2)))
    Next ii, i
    [a1].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

---

@Aussiebear
thanks , but I just see make headers without show anything under headers!:eek:

@June7
thanks, but there is syntax error in this line. so I can't test it !:think:

Code:

---

Public Function ListFileTypes(strPath As String, Optional strFileSpec As String, _ Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)

---

thanks jindon .
not really sure what reason causes automation error this line !

Code:

---

Set AL = CreateObject("System.Collections.ArrayList")

---

The forum combined the first 2 lines of code. I don't know why it does that, a bug I guess. Unfortunately, can no longer edit that post. Just need to hit Enter after the underscore character so you get:

Code:

---

Public Function ListFileTypes(strPath As String, Optional strFileSpec As String, _
  Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)

---

And remove the apostrophe in front of On Error GoTo line to enable the error handler.

ok now it's gone .
but how works ?
all of codes are function so can't run !
I should call of function by macro like this

Code:

---

Sub test()Call TrailingSlash
Call FillDir
Call ListFileTypes
End Sub

---

?
that doesn't wok !

Replace GetDetails sub procedure with below.

Code:

---

Sub GetDetails(myList)
    Dim a, i&, ii&, s$, dic(2) As Object
    For i = 0 To 2
        Set dic(i) = CreateObject("Scripting.Dictionary")
    Next
    For i = 1 To UBound(myList, 2)
        dic(0)(myList(3, i)) = Empty
        dic(1)(myList(2, i)) = Empty
        s = Join(Array(myList(2, i), myList(3, i)), Chr(2))
        dic(2)(s) = dic(2)(s) + 1
    Next
    ReDim a(1 To dic(0).Count + 1, 1 To dic(1).Count + 1)
    a(1, 1) = "M - Y / EXT"
    For i = 0 To dic(0).Count - 1
        a(i + 2, 1) = dic(0).keys()(i)
    Next
    For i = 0 To dic(1).Count - 1
        a(1, i + 2) = dic(1).keys()(i)
    Next
    For i = 2 To UBound(a, 1)
        For ii = 2 To UBound(a, 2)
            a(i, ii) = dic(2)(Join(Array(a(1, ii), a(i, 1)), Chr(2)))
    Next ii, i
    With [a1].Resize(UBound(a, 1), UBound(a, 2))
        .CurrentRegion.ClearContents
        .Value = a
        .Offset(, 1).Resize(, .Columns.Count - 1).Sort .Rows(1), Orientation:=2
        .Sort .Columns(1), Header:=xlYes, Orientation:=1
    End With
End Sub

---

You call only ListFileTypes function. Read the code and you will see where the other two are called.

Notice how the first two lines were combined in your posted code.

You need to provide input to the required argument.

Code:

---

Sub test()
Call ListFileTypes("Your folder path here")
End Sub

---

Quote:

---

You call only ListFileTypes function

---

doesn't work , show compile error argument not optional!

excellent jindon ! :clap:
thank you so much.

Correct, argument is required.
I edited my earlier post, review again.

Quote:

---

Correct, argument is required.
I edited my earlier post, review again.

---

Looks like I missed an edit.

Change colDirList to dicDirList.

Also, if you want to pull from subfolders, need to supply optional argument.

Code:

---

Sub test()
Call ListFileTypes("Your folder path here", , True)
End Sub

---

still the same error !

I copy/pasted my posted code into a module, made the 3 edits I described, called the procedure as indicated. It works.

The edits were:
1. break first line into 2 lines after the underscore
2. change colDirList to dicDirList
3. uncomment the On Error line

You can also comment or delete the Debug.Print line if you don't want that output.

Quote:

---

2. change colDirList to dicDirList

---

OMG!:bug::bug:
I forgot that when you mentioned in post#17

Quote:

---

Change colDirList to dicDirList.

---

this is I missed ,sorry!: pray2:
your code works perfectly.:thumb
thank you so much.:friends: