Speed this up

[Sahil123]

Hi - Im trying to list out the names of all folders and files in a folder and also get the size, name, modified etc

I also am excluding any hidden files as this appears to be included in my count. Im trying to get a count of all the sub folders and count of all files also

This code appears to work for me but has been running for an hour or so and then my system crashed as there is that many subfolders and files in the root folder

Please help me speed this up

Thank You

Sub ListFiles()

    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    
    'Declare the variables
    Dim objFSO As Scripting.FileSystemObject
    Dim objTopFolder As Scripting.Folder
    Dim strTopFolderName As String
    
    Application.ScreenUpdating = False
    
    'Assign the top folder to a variable
    FolderPath = "S:\CR\Resource Planning\"
     
   'With Sheet1
      
    'Insert the headers for Columns A through F
    Range("A1").Value = "Folder Path"
    Range("B1").Value = "Folder Name"
    Range("C1").Value = "File Name"
    Range("D1").Value = "File Size"
    Range("E1").Value = "Date Created"
    Range("F1").Value = "Date Last Accessed"
    Range("G1").Value = "Date Last Modified"
    Range("H1").Value = "Count of Subfolders"
    Range("I1").Value = "Count of Files"
    
   'End With
    
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Get the top folder
    Set objTopFolder = objFSO.GetFolder(FolderPath)
    
    'Call the RecursiveFolder routine
    Call RecursiveFolder(objTopFolder, True)
    
    'Change the width of the columns to achieve the best fit
    Columns.AutoFit
        
        Application.ScreenUpdating = True
        
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, _
    IncludeSubFolders As Boolean)
    'Declare the variables
    Dim objFile As Scripting.File
    Dim objSubFolder As Scripting.Folder
    Dim NextRow As Long
    Dim fileCount As Long
    
    'Find the next available row
    NextRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
    
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
       If Not objFile.Attributes And 2 Then
            Cells(NextRow, "A").Value = objFolder.Path
            Cells(NextRow, "B").Value = objFolder.Name
            Cells(NextRow, "C").Value = objFile.Name
            Cells(NextRow, "D").Value = Round(objFile.Size / 1024, 2)
            Cells(NextRow, "E").Value = objFile.DateCreated
            Cells(NextRow, "F").Value = objFile.DateLastAccessed
            Cells(NextRow, "G").Value = objFile.DateLastModified
                For Each File In objFolder.Files
                    If (File.Attributes And vbHidden) = 0 Then fileCount = fileCount + 1
                        If Cells(NextRow, "B") <> Cells(NextRow - 1, "B") Then
                           Cells(NextRow, "H").Value = objFolder.subfolders.Count
                           Cells(NextRow, "I").Value = fileCount
                        Else
                           Cells(NextRow, "H").Value = 0
                           Cells(NextRow, "I").Value = 0
                        End If
                Next File
            NextRow = NextRow + 1
        End If
        fileCount = 0
    Next objFile
    
    
    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.subfolders
            Call RecursiveFolder(objSubFolder, True)
       Next objSubFolder
    End If
    
End Sub

 

[Sahil123]

8 hours and counting and its on 10,600 records/files .. there is another 40k files to go through

 

[Anthony47]

8 hours and counting and its on 10,600 records/files .. there is another 40k files to go through

Your code contains a useless and cpu-sucking loop that, at any file, scans all the files in the direcory (For Each File In objFolder.Files /Next File); it has a meaning on the first file, but it is meaningless on the remaining files.

The following code controls that the loop is executed only once:

Sub RecursiveFolder(objFolder As Scripting.Folder, _
 IncludeSubFolders As Boolean)
 'Declare the variables
 Dim objFile As Scripting.File
 Dim objSubFolder As Scripting.Folder
 Dim NextRow As Long
 Dim fileCount As Long
Dim Begin As Long           '<<<< New Variable ***
If myDEB Then Debug.Print "Start Recursive"                 '***
If myDEB Then Debug.Print objFolder.Name, objFolder.Path    '***
 'Find the next available row
 NextRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
Begin = 0           '***

 'Loop through each file in the folder
 For Each objFile In objFolder.Files
 DoEvents
    If Not objFile.Attributes And 2 Then
         Cells(NextRow, "A").Value = objFolder.Path
         Cells(NextRow, "B").Value = objFolder.Name
         Cells(NextRow, "C").Value = objFile.Name
         Cells(NextRow, "D").Value = Round(objFile.Size / 1024, 2)
         Cells(NextRow, "E").Value = objFile.DateCreated
         Cells(NextRow, "F").Value = objFile.DateLastAccessed
         Cells(NextRow, "G").Value = objFile.DateLastModified
         If Begin = 0 Then              '***
             Begin = 1                  '***
             For Each File In objFolder.Files
                     If (File.Attributes And vbHidden) = 0 Then fileCount = fileCount + 1
                     If Cells(NextRow, "B") <> Cells(NextRow - 1, "B") Then
                        Cells(NextRow, "H").Value = objFolder.SubFolders.Count
                        Cells(NextRow, "I").Value = fileCount
                     Else
                        Cells(NextRow, "H").Value = 0
                        Cells(NextRow, "I").Value = 0
                     End If
             Next File
         End If                         '***
         NextRow = NextRow + 1
     End If
     fileCount = 0
If myDEB Then Debug.Print "Next objFile"    '***
 Next objFile
 
 'Loop through files in the subfolders
 If IncludeSubFolders Then
     For Each objSubFolder In objFolder.SubFolders
         Call RecursiveFolder(objSubFolder, True)
    Next objSubFolder
 End If
End Sub

There are some new instructions, they are marked ***

I also modified Sub ListFiles to get debugging information; again the added lines are marked ***

Dim myDEB As Boolean        'ON TOP of the vba Module     '***
Sub ListFiles()
myDEB = False               'TRUE if you wish gettin intermediate info in the Immediate windows
 
 'Set a reference to Microsoft Scripting Runtime by using
 'Tools > References in the Visual Basic Editor (Alt+F11)
 
 'Declare the variables
 Dim objFSO As Scripting.FileSystemObject
 Dim objTopFolder As Scripting.Folder
 Dim strTopFolderName As String
 Application.ScreenUpdating = False
 'Assign the top folder to a variable
    FolderPath = "S:\CR\Resource Planning\"
' FolderPath = "D:\Pictures\"
'With Sheet1
' ActiveSheet.Cells.ClearContents            '<<< Enable to CLEAR the SHEET at Start
 'Insert the headers for Columns A through F
 Range("A1").Value = "Folder Path"
 Range("B1").Value = "Folder Name"
 Range("C1").Value = "File Name"
 Range("D1").Value = "File Size"
 Range("E1").Value = "Date Created"
 Range("F1").Value = "Date Last Accessed"
 Range("G1").Value = "Date Last Modified"
 Range("H1").Value = "Count of Subfolders"
 Range("I1").Value = "Count of Files"
 
'End With
myTim As Single                                         '***
myTim = Timer
If myDEB Then Debug.Print vbCrLf & "START >>>"          '***
 'Create an instance of the FileSystemObject
 Set objFSO = CreateObject("Scripting.FileSystemObject")
 
 'Get the top folder
 Set objTopFolder = objFSO.GetFolder(FolderPath)
 
 'Call the RecursiveFolder routine
 Call RecursiveFolder(objTopFolder, True)
 
If myDEB Then Debug.Print "Completed: " & Format(Timer - myTim, "0.00")    '***
MsgBox ("Completed: " & Format(Timer - myTim, "0.00"))          '***
 'Change the width of the columns to achieve the best fit
 Columns.AutoFit
 Application.ScreenUpdating = True
'
End Sub

I used variable myDEB to enable /disable printing the debugging information; since debugging lines are inserted both in the Sub ListFiles and Sub RecursiveFolder, myDEB has to be declared on top of the vba Module, before any Sub or Function.

Hth

 

[Sahil123]

Thank you

i will give that a go

would be even quicker if i loaded it into an array 1st and then printing it on the spreadsheet afterwards at the end?

if yes, can you please help me with that

 

[Anthony47]

Thank you

i will give that a go

would be even quicker if i loaded it into an array 1st and then printing it on the spreadsheet afterwards at the end?

if yes, can you please help me with that

Yes, writing to an array and dumping the array to the worksheet at the end wound be "even faster"; however this is a process where most of the time is spent in I/O, I would expect only a marginal improvement.

We'll evaluate that option when we know the new performances

Bye