Count of Files in folders and subfolders

HI,


iam looking for a solution to count the files in folders & subfolders , calling for a path from the Main DIR.

The output will be Main folder name
(1) Primary folder  (Only name mostly)    (2) All the list of subfolders with count of files    (3) Only file extension.

This will include any empty folders

Also wish to know if any alternate tools which can copy large files in lesser time. ( From Dir to Dir). I have tried xcopy on Dos prompt even though it takes lot of time.
CPHAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Gustav BrockCIOCommented:
These two functions will do the counting:

' Lists the files of a folder and its subfolders
' including the subfolder name but without the
' root path (drive letter and parent folder).
'
' Returns the count of files.
'
' Will fail if permission to a subfolder is denied.
'
' Example:
'   FileCount = ListFolderFiles("C:\Windows")
'   will list:
'       bfsvc.exe
'       bootstat.dat
'       ...
'       addins\FXSEXT.ecf
'       appcompat\appraiser\APPRAISER_FileInventory.xml
'       ...
'
' 2017-10-22. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function ListFolderFiles( _
    ByVal Path As String) _
    As Long
    
    Dim FileNames   As Variant
    Dim Item        As Long
    
    FileNames = FolderFileNames(Path)
    If Not IsEmpty(FileNames) Then
        For Item = LBound(FileNames) To UBound(FileNames)
            Debug.Print FileNames(Item)
        Next
    End If
    
    ListFolderFiles = Item

End Function


' Returns an array of file names of the specified Path
' and its subfolders including subfolder name but without
' the root path (drive letter and parent folder).
' Names of subfolders themselves are excluded.
'
' The array holds one file name, if Path is a file.
'
' Will fail if permission to a subfolder is denied.
'
' Example:
'   FileNameArray = FolderFileNames("C:\Windows\bootstat.dat")
'   will hold:
'       bootstat.dat
'
'   FileNameArray = FolderFileNames("C:\Windows")
'   will hold:
'       bfsvc.exe
'       bootstat.dat
'       ...
'       addins\FXSEXT.ecf
'       appcompat\appraiser\APPRAISER_FileInventory.xml
'       ...
'
' Format is similar to the DOS command with no root path:
'   Dir "C:\Windows" /A:-D /B /S
'   that will output:
'       C:\Windows\bfsvc.exe
'       C:\Windows\bootstat.dat
'       ...
'       C:\Windows\addins\FXSEXT.ecf
'       C:\Windows\appcompat\appraiser\APPRAISER_FileInventory.xml
'       ...
'
' Parameter ParentFolderName is for internal use only and
' must not be specified initially.
'
' 2017-10-22. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function FolderFileNames( _
    ByVal Path As String, _
    Optional ByVal ParentFolderName As String) _
    As Variant

    Dim FileSystemObject    As Scripting.FileSystemObject
    Dim Folder              As Scripting.Folder
    Dim SubFolder           As Scripting.Folder
    Dim Files               As Scripting.Files
    Dim File                As Scripting.File
    Dim FileList            As Variant
    Dim FileListSub         As Variant

    Set FileSystemObject = New FileSystemObject
    
    If FileSystemObject.FolderExists(Path) Then
        Set Folder = FileSystemObject.GetFolder(Path)
        Set Files = Folder.Files
    
        For Each File In Files
            If IsEmpty(FileList) Then
                FileList = Array(FileSystemObject.BuildPath(ParentFolderName, File.Name))
            Else
                FileList = Split(Join(FileList, ":") & ":" & FileSystemObject.BuildPath(ParentFolderName, File.Name), ":")
            End If
        Next
        For Each SubFolder In Folder.SubFolders
            FileListSub = FolderFileNames(SubFolder.Path, FileSystemObject.BuildPath(ParentFolderName, FileSystemObject.GetBaseName(SubFolder)))
            If Not IsEmpty(FileListSub) Then
                If IsEmpty(FileList) Then
                    FileList = FileListSub
                Else
                    FileList = Split(Join(FileList, ":") & ":" & Join(FileListSub, ":"), ":")
                End If
            End If
        Next
    ElseIf FileSystemObject.FileExists(Path) Then
        FileList = Array(FileSystemObject.GetFile(Path).Name)
    Else
        ' Nothing to return.
        ' Return Empty.
    End If
    
    FolderFileNames = FileList
    
End Function

Open in new window

/gustav
0
Bill PrewCommented:
Try ROBOCOPY instead of XCOPY for the Dir to Dir copying...

Robocopy


»bp
0
CPHAuthor Commented:
HI, I was unable to try it... needs to call for DIr, so that i can select the DIR
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

CPHAuthor Commented:
Hi Bill Prew,

For some unknown reason Robocopy did not work on my system.

Thanks!
0
Gustav BrockCIOCommented:
It is not quite clear what you want. Dir doesn't select a "dir" (folder).

/gustav
0
KimputerCommented:
For finding files, I have made this small .Net app a long time ago (FindFoldersWithManyFiles.exe):

https://drive.google.com/open?id=0B5vWLrzEkj6DNTFESDhoLU5jZEE


Originally made to find only big folders. But if you want to see all folder, fill in 0 in the appropiate field

Also note, big files usually take a long time! The program usually can't do it faster, even if you change from xcopy to robocopy or any other program.
Just monitor disk speed to compare the programs, you'll probably see they're maxed out at xx MB/s (which is probably the rated hard disk speed for that model).
0
CPHAuthor Commented:
Hi gustav,
I was looking for folder selection option. For instance when i run the macro it need to ask for the folder path.
Select the folder and run the macro.

Thanks!
0
Gustav BrockCIOCommented:
Here is an example using: FileDialog

/gustav
0
CPHAuthor Commented:
Hi Kimputer,

The tool is similar what Iam looking for. But few requirement which will help me achieve the goal.
1. There is no export function
2. The full path is not required ( only folder name)
3.Total count of files
4.Split of file count according to extn

Thanks!
0
KimputerCommented:
With that many extra requirements, it should really be a Gigs instead:
https://www.experts-exchange.com/gigs/
1
aikimarkCommented:
How deep do you want this subfolder traversal to go?
0
Bill PrewCommented:
Can you provide a sample showing the files and folders and subfolders you use in a test, and then the output you would want, with example folders and counts and how it would be organized.


»bp
0
CPHAuthor Commented:
HI,
 Bill Prew / Kimputer

I do not know if Iam confusing the requirement . Please find the attached.



Thanks!
CPH
This-is-purely-an-excel-based-macro.docx
0
Gustav BrockCIOCommented:
This expert suggested creating a Gigs project.
You have the bits and pieces here.

If you want a ready boiled solution, you should open a project in Gigs.

/gustav
0
CPHAuthor Commented:
Hi All,

In Simple lines Iam looking for the DOS cmd       "dir *.* /w /s "   which will display Total no of DIR and no of Files.

Please convert the DOS option to Macros where I can get the List of DIR along with count of Files in Excel.

Thanks!
0
aikimarkCommented:
Do you want this as the list of directory names?
dir /ad /s /b /-C

Open in new window

0
aikimarkCommented:
Do you need the total number of files or the total number of files in each directory?
0
CPHAuthor Commented:
HI Aikimark,
I need count of files in each sub Dir , including any empty dir which will display as "0"

Thanks!
0
Bill PrewCommented:
Okay, here is a workbook with a VBA macro in it you can run called CountExt.  It will prompt for the base folder to start from, then add a new sheet to the end and populate it with the info I *think* you are looking for.  A sample sheet that I ran here is included, but when you test it you will get a new sheet added for your data.  See what you think...

EE29065834.xlsm


»bp
0
aikimarkCommented:
This function uses the dir and findstr commands to gather the data.  Then the data is transformed into an array containing the directory name, file count, and number of bytes.
Function Q_29065834(ByVal parmTopDir As String)
    Dim strData As String
    Dim oWSH As Object
    
    Dim oFS, oTS
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

    Static oRE As Object

    Set oWSH = CreateObject("wscript.shell")
    oWSH.Run "cmd /c cd " & parmTopDir & " & dir /w /s | findstr ""File(s) Directory"" > Q_29065834.txt", 0, True
    
    Set oFS = CreateObject("scripting.filesystemobject")
    Set oTS = oFS.OpenTextFile(parmTopDir & "\Q_29065834.txt", ForReading, True, TristateFalse)
    strData = oTS.readall
    oTS.Close
    
    strData = Replace(strData, " Directory of ", "")
    'remove file count summary lines
    strData = Left(strData, InStrRev(strData, "File(s)") - 1)
    strData = Left(strData, InStrRev(strData, vbCrLf) - 1)
    
    Set oRE = CreateObject("vbscript.regexp")
    oRE.Global = True
    oRE.Pattern = "\r\n +"

    If oRE.test(strData) Then
        strData = oRE.Replace(strData, vbTab)
    End If
    
    oRE.Pattern = "(File\(s\))( +)"
    strData = oRE.Replace(strData, "$1" & vbTab)
    
'    Set oTS = oFS.OpenTextFile(parmTopDir & "\Q_29065834.txt", ForWriting, True, TristateFalse)
'    oTS.write strData
'    oTS.Close
    
    Q_29065834 = Split(strData, vbCrLf)

End Function

Open in new window

Example invocation:
x = Q_29065834(environ("homepath") & "\downloads")

?ubound(x)
 4885 

?x(0)
C:\Users\Mark\Downloads 1628 File(s)  9,687,821,627 bytes

?x(4885)
C:\Users\Mark\Downloads\XmlPad302azip   1 File(s)     10,989,479 bytes

Open in new window

0
aikimarkCommented:
Note: I edited my posted code snippet to replace spaces after "File(s)" with a tab character.  This would make it easier to split the array item into its three constituent data.
0
aikimarkCommented:
The Findstr command doesn't do a proper job of filtering.  So, I do all the parsing in this version of the VBA code.  Regular expressions to the rescue.
Function Q_29065834(ByVal parmTopDir As String)
    Dim strData As String
    Dim oWSH As Object
    
    Dim oFS, oTS
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

    Dim oRE As Object
    Dim oMatches As Object
    Dim lngMatch As Long
    
    Dim vResult As Variant
    
    Set oWSH = CreateObject("wscript.shell")
    oWSH.Run "cmd /c cd " & parmTopDir & " & dir /-C /w /s > Q_29065834.txt", 0, True
    
    Set oFS = CreateObject("scripting.filesystemobject")
    Set oTS = oFS.OpenTextFile(parmTopDir & "\Q_29065834.txt", ForReading, True, TristateFalse)
    strData = oTS.readall
    oTS.Close
    
    Set oRE = CreateObject("vbscript.regexp")
    oRE.Global = True
    oRE.Pattern = "(?:\n|^) Directory of (\S[^\r]+\S)\r\n(?:.|\n)+?(?= +\d+ File\(s\)) +(\d+) File\(s\) +(\d[^ ]*) bytes"

    If oRE.test(strData) Then
        Set oMatches = oRE.Execute(strData)
        ReDim vResult(0 To oMatches.Count - 1)
        For lngMatch = 0 To oMatches.Count - 1
            With oMatches(lngMatch)
                vResult(lngMatch) = .submatches(0) & vbTab & .submatches(1) & vbTab & .submatches(2)
            End With
        Next
    End If
    
    Q_29065834 = vResult
End Function

Open in new window

0
aikimarkCommented:
I worked out the Findstr problem.  This version of the function returns a 2D array.  No need to use the Split() function on the results.
Function Q_29065834a(ByVal parmTopDir As String)
    Dim strData As String
    Dim oWSH As Object
    
    Dim oFS, oTS
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

    Dim oRE As Object
    Dim oMatches As Object
    Dim lngMatch As Long
    Dim lngSM As Long
    
    Dim vResult As Variant
    
    Set oWSH = CreateObject("wscript.shell")
    oWSH.Run "cmd /c cd " & parmTopDir & " & dir /-C /w /s | findstr /R ""^ Directory of | File\(s\) "" > Q_29065834.txt", 0, True
    
    Set oFS = CreateObject("scripting.filesystemobject")
    Set oTS = oFS.OpenTextFile(parmTopDir & "\Q_29065834.txt", ForReading, True, TristateFalse)
    strData = oTS.readall
    oTS.Close
    oFS.deletefile parmTopDir & "\Q_29065834.txt"
    
    Set oRE = CreateObject("vbscript.regexp")
    oRE.Global = True
    
    'remove totals at the end
    oRE.Pattern = "( +(\d+) File\(s\) +(\d[^ ]*) bytes)\r\n +(\d+) File\(s\) +(\d[^ ]*) bytes\s+$"
    If oRE.test(strData) Then
        strData = oRE.Replace(strData, "$1")
    End If
    
    oRE.Pattern = "(?:\n|^) Directory of (\S[^\r]+\S)\r\n(?:.|\n)+?(?= +\d+ File\(s\)) +(\d+) File\(s\) +(\d[^ ]*) bytes"
    If oRE.test(strData) Then
        Set oMatches = oRE.Execute(strData)
        strData = vbNullString
        ReDim vResult(0 To oMatches.Count - 1, 0 To oMatches(0).submatches.Count - 1)
        For lngMatch = 0 To oMatches.Count - 1
            With oMatches(lngMatch)
                For lngSM = 0 To .submatches.Count - 1
                    vResult(lngMatch, lngSM) = .submatches(lngSM)
                Next
            End With
        Next
    End If
    
    Q_29065834a = vResult
End Function

Open in new window

0
CPHAuthor Commented:
HI, Aikimark

It will be great if  you add a line of code for the user to pick the folder and process.

Hi,Bill Prew
The output was interesting , but  the actual DIR  output exceeded the excel row limit, hence could not proceed. This will be good if the output is continued in the next sheet of workbook..... Also remove the size as it is not required.

What i thought if the header is unique as per the extn i can save every alternate rows . (As per enclosure)

Thanks!
CPH
File-count.xlsx
0
aikimarkCommented:
@CPH
if  you add a line of code
What I've posted is a function where you pass the top level directory (string).  Prompting the user is what you do OUTSIDE of this function, using the Application.Dialogs().Show method.
0
Bill PrewCommented:
but  the actual DIR  output exceeded the excel row limit

You are doing this for over a million files ???


»bp
0
aikimarkCommented:
I did some simplification of the patterns and squeezed a little more performance out of the function.
Function Q_29065834a(ByVal parmTopDir As String)
    Dim strData As String
    Dim oWSH As Object
    
    Dim oFS, oTS
    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

    Dim oRE As Object
    Dim oMatches As Object
    Dim lngMatch As Long
    Dim lngSM As Long
    
    Dim vResult As Variant
    
    Set oWSH = CreateObject("wscript.shell")
    oWSH.Run "cmd /c cd " & parmTopDir & " & dir /-C /w /s | findstr /R /c:""^ "" > Q_29065834.txt", 0, True
    
    Set oFS = CreateObject("scripting.filesystemobject")
    Set oTS = oFS.OpenTextFile(parmTopDir & "\Q_29065834.txt", ForReading, True, TristateFalse)
    strData = oTS.readall
    oTS.Close
    oFS.deletefile parmTopDir & "\Q_29065834.txt"
    
    Set oRE = CreateObject("vbscript.regexp")
    oRE.Global = True
    oRE.Pattern = "\n Directory of ([^\r]+)\r\n +(\d+) File\(s\) +(\d+)"
    
    If oRE.test(strData) Then
        Set oMatches = oRE.Execute(strData)
        strData = vbNullString
        ReDim vResult(0 To oMatches.Count - 1, 0 To oMatches(0).submatches.Count - 1)
        For lngMatch = 0 To oMatches.Count - 1
            With oMatches(lngMatch)
                For lngSM = 0 To .submatches.Count - 1
                    vResult(lngMatch, lngSM) = .submatches(lngSM)
                Next
            End With
        Next
    Else
        MsgBox "Regex pattern not matched"
    End If
    
    Q_29065834a = vResult
End Function

Open in new window

0
aikimarkCommented:
I would ask: Are you doing this for over a million directories?!?
0
Bill PrewCommented:
Thanks aikimark, agreed, worded wrong, I was caught up in the thought of running this against so many folders and files.


»bp
0
aikimarkCommented:
Yes.  Not sure what my function will do with data this size.  The Regex engine can fail (or fail to complete) for memory reasons.  I've been testing with a directory tree that is a little less than 5000 directories.  CPH is planning to throw 200 times that data at the function.
1
CPHAuthor Commented:
Hi Bill Prew / Aikimark ,

Good! It actually relaxed my nerves for a while....   based on Bill Prew's  solution , it creates output in 2 rows . I was trying  to make a point to have a unique header, so that output remains in single row.

Thanks!
CPH
0
Bill PrewCommented:
Adjusting to single row format...


»bp
0
Bill PrewCommented:
Okay, this removes the SIZE column, and places each folder on a single row.  It also skips any folders you don't have access to.

I didn't add multiple sheets, I really don't understand how you could be using this for more than 1,000,000 folders?  And that gets interesting, since future sheets could be adding new extensions that haven't been hit yet, so then the extension columns are different between sheets, etc.

I've invested a number of hours into this now, can I ask, what are you using this data for !?

Option Explicit

' Global variables
Dim objFSO As FileSystemObject
Dim objSheet As Worksheet
Dim lngRow As Long
Dim lngCol As Long


Public Sub CountExt()
   Dim strFolder As String
   Dim strDefaultFolder As String

   ' Reference to filesystem object
   Set objFSO = New FileSystemObject

   ' Define default folder for folder selector (or blank)
   strDefaultFolder = "C:\"
   
   ' Let user pick a folder to process, and then process it
   strFolder = PickFolder(strDefaultFolder)
   If strFolder <> "" Then
      If objFSO.FolderExists(strFolder) Then
         BuildSheet objFSO.GetFolder(strFolder)
      End If
   End If
   
   Set objFSO = Nothing
End Sub

Private Sub BuildSheet(objFolder As Object)
    ' Add new sheet for this folders stats
    Set objSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    objSheet.Activate

    ' Add Column Headers
    lngRow = 1
    objSheet.Cells(lngRow, 1) = "Folder"
    objSheet.Cells(lngRow, 1).Font.Bold = True
    objSheet.Cells(lngRow, 2) = "Files"
    objSheet.Cells(lngRow, 2).Font.Bold = True
    lngCol = -1
  
    ' Disable screen updates
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    
    ' Process this folder (recursively)
    ProcessFolder objFolder
   
    ' If files were found, sort extensions alphabetically
    If lngCol <> -1 Then
        objSheet.Sort.SortFields.Clear
        objSheet.Sort.SortFields.Add Key:=Range(objSheet.Cells(1, 3), objSheet.Cells(1, lngCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With objSheet.Sort
            .SetRange Range(objSheet.Cells(1, 3), objSheet.Cells(lngRow, lngCol))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlLeftToRight
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
   
    ' Autofit column widths to data
    objSheet.Range(objSheet.Cells(1, 1), objSheet.Cells(1, lngCol)).EntireColumn.AutoFit
    
    ' Position to top of sheet
    objSheet.Cells(1, 1).Select
    
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True

End Sub
    
Private Sub ProcessFolder(objFolder As Object)
    Dim objSubFolder As Object
    Dim objFile As Object
    
    ' Advance to next set of rows for this folders stats, alternate row color for readability
    lngRow = lngRow + 1
    
    ' Add basic info for this folder
    objSheet.Cells(lngRow, 1) = objFolder.Path
    On Error Resume Next
    objSheet.Cells(lngRow, 2) = objFolder.Files.Count
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If
    Err.Clear
    On Error GoTo 0

    ' Process all files in this folder
    For Each objFile In objFolder.Files
        ProcessFile objFile
    Next
    
    ' Drill down into each subfolder, recursively
    For Each objSubFolder In objFolder.Subfolders
        ProcessFolder objSubFolder
    Next
End Sub

Private Sub ProcessFile(objFile As Object)
    ' Local variables
    Dim varMatch As Variant
    Dim strExt As String
    
    ' Get the extension of this file (use *NONE to indicate blank extension)
    strExt = UCase(objFSO.GetExtensionName(objFile.Path))
    If strExt = "" Then
        strExt = "*NONE"
    End If
    
    ' If first extension ever found, always add it's extension to the table
    If lngCol = -1 Then
        lngCol = 3
        objSheet.Cells(1, lngCol) = strExt
        objSheet.Cells(1, lngCol).Font.Bold = True
        objSheet.Cells(lngRow, lngCol) = 1
        Exit Sub
    End If

    ' See if this extension already found
    varMatch = Application.Match(strExt, objSheet.Range(objSheet.Cells(1, 3), objSheet.Cells(1, lngCol)), 0)

    ' If we found a match then update count, otherwise add this new extension to the table
    If IsError(varMatch) Then
        lngCol = lngCol + 1
        objSheet.Cells(1, lngCol) = strExt
        objSheet.Cells(1, lngCol).Font.Bold = True
        objSheet.Cells(lngRow, lngCol) = 1
    Else
        objSheet.Cells(lngRow, 3).Offset(0, varMatch - 1) = objSheet.Cells(lngRow, 3).Offset(0, varMatch - 1) + 1
    End If
End Sub
    
    
Private Function PickFolder(strPath As String) As String
   Dim objDialog As FileDialog
   Dim strSelect As String

   strSelect = strPath

   ' Let user pick a folder
   Set objDialog = Application.FileDialog(msoFileDialogFolderPicker)
   With objDialog
      .Title = "Select a Folder"
      .AllowMultiSelect = False
      .InitialFileName = strPath
      If .Show = -1 Then
         strSelect = .SelectedItems(1)
      End If
   End With

   PickFolder = strSelect
End Function

Open in new window


»bp
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
CPHAuthor Commented:
Thanks! Bill Prew,

It is the folders which got duplicated during various backups and systems .It is for a cleanup process.

Thanks!
CPH
0
CPHAuthor Commented:
Thanks!  to Bill Prew  with the final solution and Aikimark  for the contribution.

Thanks!
CPH
0
aikimarkCommented:
If you stored the results in an array, you could transfer the data in a single operation.  It's quite fast.
https://www.experts-exchange.com/articles/2253/Fast-Data-Push-to-Excel.html
0
aikimarkCommented:
per OP comment
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.