Ken Duls posted this code sometime back and it looks beautiful. Unfortunately, no that Application.FileSearch is gone it doesn't work. This is exactly what I'm trying to do now in Excel 2013.
I want to build a formula in a workbook that will display the current number of files within a folder as a way of showing how much paperwork has yet to be processed.
Option Compare Text Option Explicit Function CountFiles(Directory As String, Optional Ext As String = "All") As Double 'Function purpose: To count all the files in a directory 'Alternate purpose: To count all files in a directory with a specified file extension 'Method: If a file extension is supplied as an arguement, we can cut down on the list ' of files to filter through by calling only files that are in the same ' msoFileType group. (ie .doc and .dot files belong to the WordDocuments ' group, but not the ExcelWorkbooks group. This will allow us to count the ' number of files matching the extension more quickly, since we will only ' operate on files that belong to that group, not all groups. If no file ' extension is supplied (or the file does not belong to any specified group,) ' we can still resort to counting all files. Dim fs As Object, i As Integer 'Create the FileSearch object Set fs = Application.FileSearch 'If an empty string has been passed as the file extension, set it to "All" If Len(Ext) < 3 Then Ext = "All" With fs 'Set the directory to look in to the directory arguement supplied by the user .LookIn = Directory 'Determine the msoFileType group that the file extension belongs to. .FileType = GetMSOFileType(Ext) 'Execute the search .Execute If Ext = "All" Then 'If no file extension supplied, count all files in the directory CountFiles = .FoundFiles.count Else 'If a file extension is supplied count the number of files in the 'filtered list which match the supplied extension For i = 1 To .FoundFiles.count If Right(.FoundFiles.Item(i), 3) = Right(Ext, 3) Then _ CountFiles = CountFiles + 1 Next i End If End With 'Release the FileSearch object Set fs = Nothing End Function Function GetMSOFileType(FileExt As String) As Double 'Function purpose: To determine the msoFileType of a file extension 'Note: If a file extension does not exist in the list, the file type will default ' to AllFiles. More msoFileTypes can be found by looking up the "FileType Property" ' in the VBA help, or on Sheet2 of the example workbook Select Case Right(FileExt, 3) Case Is = "doc", "dot" 'Assign file type of msoFileTypeWordDocuments 'NOTE: msoFileTypeWordDocuments does not include "rtf" files GetMSOFileType = 3 Case Is = "xls", "xla", "xlt", "xlc", "xlm" 'Assign file type of msoFileTypeExcelWorkbooks 'NOTE: msoFileTypeExcelWorkbooks does not include "xll" or "xlw" files GetMSOFileType = 4 Case Is = "ppt", "pps", "pot" 'Assign file type of msoFileTypePowerPointPresentations GetMSOFileType = 5 Case Is = "mdb", "mde", "ade", "adp" 'Assign file type of msoFileTypeDatabases 'NOTE: msoFileTypeDatabases does not include "mda" files GetMSOFileType = 7 Case Is = "pub" 'If XL2002 or later, assign file type of msoFileTypePublisherFiles 'otherwise, assign file type of msoFileTypeAllFiles If Val(Application.Version) < 10 Then GetMSOFileType = 1 Else GetMSOFileType = 18 End If Case Is = "vsd", "vss", "vst" 'If XL2002 or later, assign file type of msoFileTypeVisioFiles 'otherwise, assign file type of msoFileTypeAllFiles 'NOTE: msoFileTypeVisioFiles does not include "vsw", "vdx", "vsx" or "vtx" files If Val(Application.Version) < 10 Then GetMSOFileType = 1 Else GetMSOFileType = 21 End If Case Is = "htm", "tml", "mht" 'If XL2002 or later, assign file type of msoFileTypeWebPages 'otherwise, assign file type of msoFileTypeAllFiles If Val(Application.Version) < 10 Then GetMSOFileType = 1 Else GetMSOFileType = 23 End If Case Else 'Assign file type of msoFileTypeAllFiles GetMSOFileType = 1 End Select End Function
Reply With Quote
Originally Posted by smithr8
