I found this code which counts files in a folder & subfolders, with a specific string in the filename.
I want to amend it so that it counts files with the same name as the active workbook.
Criteria is:
- Without specifying in the code what the active workbook name is.
- Disregard the extension. Example, active workbook "MyFile.xlsx" counts "MyFile.pdf".
- A full match is required, no wild cards.
Does anyone have any pointers?
Link.
Sub Test()
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: Test the CountFiles function
Dim flDlg As FileDialog
Dim dblCount As Double
Set flDlg = Application.FileDialog(msoFileDialogFolderPicker)
flDlg.Show
dblCount = CountFiles_FolderAndSubFolders(flDlg.SelectedItems(1))
Debug.Print dblCount
End Sub
Private Function CountFiles_FolderAndSubFolders(strFolder As String, Optional strExt As String = "*.*") As Double
'Author : Ken Puls (www.excelguru.ca)
'Function purpose: To count files in a folder and all subfolders. If a file extension is provided,
' then count only files of that type, otherwise return a count of all files.
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
'Set Error Handling
On Error GoTo EarlyExit
'Create objects to get a count of files in the directory
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.getfolder(strFolder).Files
Set objSubFolders = objFso.getfolder(strFolder).subFolders
'Count files (that match the extension if provided)
If strExt = "*.*" Then
CountFiles_FolderAndSubFolders = objFiles.Count
Else
For Each objFile In objFiles
If UCase(Right(objFile.Path, (Len(objFile.Path) - InStrRev(objFile.Path, ".")))) = UCase(strExt) Then
CountFiles_FolderAndSubFolders = CountFiles_FolderAndSubFolders + 1
End If
Next objFile
End If
'Request count of files in subfolders
For Each objSubFolder In objSubFolders
CountFiles_FolderAndSubFolders = CountFiles_FolderAndSubFolders + _
CountFiles_FolderAndSubFolders(objSubFolder.Path, strExt)
Next objSubFolder
EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Function
Bookmarks