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]

Any luck please - Ive tried to run it again but my system is showing not responding for over 2 hours now

 

[Sahil123]

Please can someone help me speed up this code please

 

[Sahil123]

Why will no one respond and help me

 

[RobertSF]

Have you determined the code is working even if it's doing it too slowly? At first glance, I don't see any obvious inefficiencies that can be fixed. For contrast, I dropped to the command prompt and entered DIR /S /A > DIRS.TXT. On my system, it took two minutes and the resulting file was 30 MB. Would it work for you to generate the directory list that way and then use Excel only to process the list?

 

[Sahil123]

Thank you so much and I appreciate you getting back to me
I have never done it that way so thats all new to me

When I stepped through the code manually - it was pulling back the data fine. There are outlook stored messages in there so not sure if the code will pull that back and class that as a file?

not sure what else to do - it goes into Not Responding the moments i run the code at once - not sure what else i should do

 

[Sahil123]

The code appears to be working although it says NOT WORKING

ive read that the code might be quicker to add DOEVENTS and storing into an array

can you or anyone please help me with this if it will speed things up

thank you

 

[RobertSF]

I think nobody is responding because you're asking a pretty challenging question!

The message "Not Responding" doesn't necessarily mean the program is not working or has crashed. It might be working fine and just not responding to Windows when it says, "Hey, you there?" If the program is running and not caught in an infinite loop, it will eventually finish even though it says "Not Responding."

Emails can be stored in one huge PST file or they can be stored individually as EML files (which are just text files). Either way, they are just ordinary files.

I really can't offer any suggestions, I'm sorry to say. But perhaps these two links might help you.
https://stackoverflow.com/questions/20687810/vba-macro-that-search-for-file-in-multiple-subfolders
https://www.youtube.com/watch?v=ZL-3mqF7WDk

 

[Sahil123]

Thank you

 

[Sahil123]

Hopefully 1 of the MVPs can help with an alternative solution

thank you