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.

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.

I'm looking to optimize the code for faster performance.

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.

Looking to optimize the code for faster 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

I'm looking to optimize the code for faster 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