VBA counting & listing files in a folder

[RoundRocket]

Below is a handy bit of code in Excel 2007 which simply lists all the files it finds in a folder in the first column of the worksheet, I'd like to somehow adapt this code to just 'count' the types of files in the folder so that it looks to a folder and reports back (see below 'desired result' for example), perhaps printing it to a .txt file instead of adding the files to a worksheet...? i cant see how to do this.

desired result:
There are 23 .docs files in the folder
There are 10 .pdf files in the folder
There are 19 .xls files in the folder
There are 120 .docx files in the folder

Any help you may be able to give on this would be awesome. Also, i do hope the code below is useful to anyone else that might be looking for a 'list files in folder' macro.
Thank you.


Sub Button3_Click()
Call ListDocumentFiles


End Sub


Sub ListDocumentFiles()
Dim fso As New FileSystemObject
Dim fle As file
Dim fldr As folder
Dim i As Integer

Call ThisWorkbook.Worksheets(2).Range("A:B").Clear
With Application.FileDialog(msoFileDialogFolderPicker)
Call .Show
Set fldr = fso.GetFolder(.SelectedItems(1))
End With


For Each fle In fldr.Files
If InStr(1, fle.Name, ".", vbTextCompare) <> 0 Then
Let i = i + 1
Let ThisWorkbook.Worksheets(2).Cells(i, 1) = fle.Name
End If
Next


MsgBox ("Search complete")


Set fle = Nothing
Set fldr = Nothing
Set fso = Nothing


End Sub

 

[djreiswig]

Try this, it doesn't save to a text file as you requested, but that part shouldn't be too hard to add.

Sub ListDocumentFiles()
    Dim fso As New FileSystemObject
    Dim fle As file
    Dim fldr As folder
    Dim i As Long
    
    Call ThisWorkbook.Worksheets(1).Range("A:A").Clear
    With Application.FileDialog(msoFileDialogFolderPicker)
        Call .Show
        Set fldr = fso.GetFolder(.SelectedItems(1))
    End With
    
    Dim FileExtArr() As String 'stores unique file extensions
    Dim FileCntArr() As Long 'stores counts of files
    For Each fle In fldr.Files
        'get the file extension
        FileExt = Right(fle.Name, Len(fle.Name) - InStr(1, fle.Name, ".", vbTextCompare))
        
        'file has extension
        If FileExt <> "" Then
            'extension not in array
            If InStr(1, Join(FileExtArr, ","), FileExt) = 0 Then
                'expand the array
                'if array isn't empty
                If Join(FileExtArr) <> "" Then
                    ReDim Preserve FileExtArr(UBound(FileExtArr) + 1)
                    ReDim Preserve FileCntArr(UBound(FileCntArr) + 1)
                Else
                    'array is empty so dim to 0
                    ReDim FileExtArr(0)
                    ReDim FileCntArr(0)
                End If
                'save new extension and count of 1
                FileExtArr(UBound(FileExtArr)) = FileExt
                FileCntArr(UBound(FileCntArr)) = 1
            Else
                'find the extension in the array
                ArrIndex = Application.WorksheetFunction.Match(FileExt, FileExtArr(), 0)
                'add 1 to the count
                FileCntArr(ArrIndex - 1) = FileCntArr(ArrIndex - 1) + 1
            End If
        End If
    Next

    'save the extension list to the worksheet
    For i = 0 To UBound(FileExtArr)
        If FileCntArr(i) = 1 Then
            ThisWorkbook.Worksheets(1).Cells(i + 1, 1) = "There is " & FileCntArr(i) & " ." & FileExtArr(i) & " file in the folder"
        Else
            ThisWorkbook.Worksheets(1).Cells(i + 1, 1) = "There are " & FileCntArr(i) & " ." & FileExtArr(i) & " files in the folder"
        End If
    Next i
End Sub

 

[uncle_romania]

Hi,

This might help

Search folder directory vba

It saves it to the first worksheet rather than the second but I've adapted it to look for the file extensions you referenced

 

[RoundRocket]

Wow, thanks very much for this. I will test these out. Much appreciated

 

[RoundRocket]

Thanks very much , this works well!