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











LinkBack URL
About LinkBacks
Register To Reply

Bookmarks