count files extensions files for each month based on modified date

[abdelfattah]

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

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

[June7]

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.

[Aussiebear]

Maybe this might do what you want?



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

[June7]

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.



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.

[jindon]

See if this is how you wanted.


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

[abdelfattah]

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

[abdelfattah]

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

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

[abdelfattah]

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

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

[June7]

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:


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.

[abdelfattah]

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

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

?
that doesn't wok !

[jindon]

Replace GetDetails sub procedure with below.


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

[June7]

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.

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

[abdelfattah]

You call only ListFileTypes function
doesn't work , show compile error argument not optional!

[abdelfattah]

excellent jindon ! :clap:
thank you so much.

[June7]

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

[abdelfattah]

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

[June7]

Looks like I missed an edit.

Change colDirList to dicDirList.

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


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

[abdelfattah]

still the same error !

[June7]

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.

[abdelfattah]

2. change colDirList to dicDirList

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


Change colDirList to dicDirList.

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