3
\$\begingroup\$

I have the following code to loop through a directory of folders and print all folders names with their paths in a worksheet. This is a follow up question to this one: Excel VBA - Get Folder Names Looking for code optimization for faster and better performance.

Sub PrintFolders()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim i As Integer
    Dim Folder_Name As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ""

    Set wb = ThisWorkbook
    Set wsControl = wb.Sheets("Control"): Set wsOutput = wb.Sheets("Output")
    Folder_Name = wsControl.Cells(1, 2)
    If Folder_Name = "" Then
        MsgBox "Path location is not entered. Please enter path"
        wsControl.Cells(1, 2).Select
        End
    End If
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(Folder_Name)

    i = 1
    Dim MyArr() As Variant
    ReDim MyArr(1 To i, 1 To 2)
    On Error GoTo CleanFail

    Application.EnableCancelKey = xlErrorHandler
    Const IterationsToUpdate As Integer = 10
    For Each objSubFolder In objFolder.subfolders
        MyArr(i, 1) = objSubFolder.Name
        MyArr(i, 2) = objSubFolder.Path
        i = i + 1
            MyArr = Application.Transpose(MyArr)
            ReDim Preserve MyArr(1 To 2, 1 To i)
            MyArr = Application.Transpose(MyArr)
        If i Mod IterationsToUpdate = 0 Then
            Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
            DoEvents
        End If
    Next objSubFolder
    Application.StatusBar = ""

    wsOutput.Rows("2:1048576").Delete
    Dim Destination As Range
    Set Destination = wsOutput.Range("A2")
    Destination.Resize(UBound(MyArr, 1), UBound(MyArr, 2)).Value = MyArr
    wsOutput.Columns.EntireColumn.AutoFit: wsOutput.UsedRange.HorizontalAlignment = xlCenter
    wsOutput.Activate

    MsgBox ("Done")

    CleanExit:
    Application.StatusBar = False
    Application.StatusBar = ""
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub

    CleanFail:
    Const MsgTitle As String = "Operation not completed"
    If Err.Number = 18 Then
        MsgBox "Operation was cancelled.", vbInformation, MsgTitle
    Else
        MsgBox "An error has occurred: " & Err.Description, vbCritical, MsgTitle
    End If
    Resume CleanExit

End Sub
\$\endgroup\$
1
  • 2
    \$\begingroup\$ Awesome, welcome back! I suggest you edit this post to include a bit more context and a link to your previous post, as this is a follow-up question. \$\endgroup\$ – Mathieu Guindon Apr 11 '15 at 0:30
4
\$\begingroup\$

Performance

If you really want to squeeze out every ounce of performance, I recommend early binding the FileSystemObject and related classes. From the "What form of binding should I use" from this MSDN article:

Early binding is the preferred method. It is the best performer because your application binds directly to the address of the function being called and there is no extra overhead in doing a run-time lookup. In terms of overall execution speed, it is at least twice as fast as late binding.

Beyond that, there's not much more you can do in the way of performance. Most of the time here is going to talking to the remote file system. You could remove the ability to cancel or not update the status bar, but it's my belief the UX would suffer too much.

One thing you could do though is alter how often you update the status bar based on how many subfolders are found. Instead of having IterationsToUpdate be a constant, make it a variable and figure out a way to calculate how often the status bar should be updated using the SubFolder's Count property. Perhaps update at each 5%.

    IterationsToUpdate = CInt(Subfolders.Count * 0.05)

Update:

I changed my mind. There is something more you can do to make the performance better. Several things actually, but I'll let you decide if the second one is really worth it or not.

  1. Stop Re-dimensioning the array. You already know how big it should be, so Dim it once and only once.

    Dim MyArr(1 To objFolder.Subfolders.Count, 1 To 2) As Variant
    

    This removes a lot of overhead inside of the loop. When you ReDim Preserve, you're effectively making a copy of the array at each iteration. There's no reason to do this when you know how big the array should be up front.

2. You could unroll the loop. Be aware, that doing this will cause a maintenance headache, but it *could significantly speed up the loop through the subfolders. This works by setting multiple "positions" of your array during each iteration.

*I do mean could. There's no way of knowing if it will actually perform better or not until it is tried and benchmarked.

Unfortunately, you can't access items in the Folders collection by integral index, only by key, so unrolling the loop is not an option.


Misc

  • Why delete the entire range here? Are all of those rows always filled? Could there ever be more?

    wsOutput.Rows("2:1048576").Delete
    

    It would be better to find the last non-empty row.

  • Why are you activating here? Smells like an unintended side effect to me.

     wsOutput.Activate
    

    Perhaps you meant to select the range for the user? If so, the correct way to do that is this.

     wsOutput.Select
    
  • You don't need parenthesis here.

    MsgBox ("Done")
    

    You're wasting at least a few cycles telling the runtime to evaluate the default property of... a literal. I recommend reading over this StackOverflow Q & A that details the rules about using parenthesis in a routine call for more information.

    It would also be nice to display the "Information" icon on the message box. It's a nicer UX.

     MsgBox "Done", vbInformation
    
  • Consider using another constant here instead of the literal 18.

    If Err.Number = 18 Then
    

    It's pretty clear what's going on from the context, but if I want to know exactly what that error is, I'd have to look it up. A (well named) constant keeps the maintainer in the IDE as it removes any ambiguity.

\$\endgroup\$
4
  • \$\begingroup\$ I added an update. I found another performance optimization. \$\endgroup\$ – RubberDuck Apr 13 '15 at 18:45
  • \$\begingroup\$ @RubberDuck.Thanks for the update, although VBA won't be let me Dim an array with a variable. Dim MyArr(1 To objFolder.Subfolders.Count, 1 To 2) As Variant. Instead I had to do this to make it work Dim MyArr() As Variant ReDim MyArr(1 To objFolder.SubFolders.Count, 1 To 2) As Variant \$\endgroup\$ – Anurag Singh Apr 13 '15 at 23:31
  • \$\begingroup\$ Sorry about that. I'm also sorry I couldn't help more. I was really trying to figure out how to speed this up. \$\endgroup\$ – RubberDuck Apr 13 '15 at 23:47
  • \$\begingroup\$ No need to be sorry you have helped enough, this works wonderfully well and I learnt so much with this code. Cheers!! \$\endgroup\$ – Anurag Singh Apr 13 '15 at 23:50

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.