Как повысить производительность с помощью рекурсивного кода

Question

В приведенном ниже коде я использую рекурсию, чтобы получить список всех файлов во всех папках и подпапках, начиная с указанного c пути. У меня возникла проблема ... После запуска этого кода Excel go в состояние «Не отвечает» до тех пор, пока код не будет выполнен.

есть ли способ ... даже если для завершения sh кода требуется больше времени, но чтобы он работал без прерывания, чтобы добиться превосходства? Я уже пробовал Application.ScreenUpdating = False, но не помогает ...

Dim r As Integer

Private Sub Test()

r = 1
GetFilesInFolder "C:\Users\xxx\Documents", True

End Sub

Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)

Dim FSO
Dim SourceFolder, SubFolder
Dim FileItem

Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)

'--- Display File Name, Path, And Extension In specified cells...

Dim Ext As String
For Each FileItem In SourceFolder.Files
    Ext = VBA.Right(FileItem.Name, VBA.Len(FileItem.Name) - VBA.InStrRev(FileItem.Name, "."))
    Cells(r, 1).Formula = FileItem.Name
    Cells(r, 2).Formula = FileItem.Path
    Cells(r, 3).Formula = Ext
    r = r + 1   ' next row number
Next FileItem

'--- This is the Function to go each and Every Folder and get the Files.

If Subfolders = True Then
    For Each SubFolder In SourceFolder.Subfolders
        GetFilesInFolder SubFolder.Path, True
    Next SubFolder
End If

Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub

Answer 1

Использование следующего кода может повысить производительность:

1. Создание FSO только один раз (а не каждая рекурсия) сэкономит некоторое время.
2. Использование массива для сбора файла данные сначала будут намного быстрее. Обратите внимание, что каждое действие чтения / записи в ячейку занимает огромное количество времени. Здесь у нас есть только одно действие записи в самом конце, где мы записываем данные всего массива сразу .

Обратите внимание, что из-за того, что изменение размера многомерного массива

ReDim Preserve OutputArr(1 To 3, 1 To c)

может изменить размер только последнего измерения, которое нам нужно для обмена столбцами и строками в массиве. Чтобы получить тот же результат, что и раньше, мы транспонируем весь массив в конце при записи его в ячейки.

Option Explicit

Dim c As Long
Dim OutputArr() As Variant
Dim FSO As Object

Private Sub Test()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    c = 1 'initialize
    
    'define array size
    ReDim OutputArr(1 To 3, 1 To 1)
    'note the array is columns/rows switched because we can only resize the second dimension
    'to put it correctly in rows/columns we use Transpose later
    
    GetFilesInFolder "C:\Temp", True
    Set FSO = Nothing
    
    'write the array into the cells
    Range("A1").Resize(UBound(OutputArr, 2), UBound(OutputArr, 1)).Value = Application.WorksheetFunction.Transpose(OutputArr)
End Sub

Public Sub GetFilesInFolder(ByVal SourceFolderName As String, ByVal Subfolders As Boolean)
    Dim SourceFolder As Object, SubFolder As Variant
    Dim FileItem As Variant
    
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
    
    '--- Display File Name, Path, And Extension In specified cells...
    
    Dim Ext As String
    For Each FileItem In SourceFolder.Files
        Ext = VBA.Right$(FileItem.Name, VBA.Len(FileItem.Name) - VBA.InStrRev(FileItem.Name, "."))
        'here we work only with the array to lower read/write actions to the cells
        OutputArr(1, c) = FileItem.Name
        OutputArr(2, c) = FileItem.Path
        OutputArr(3, c) = Ext
        c = c + 1
        ReDim Preserve OutputArr(1 To 3, 1 To c) 'resize array
    Next FileItem
    
    '--- This is the Function to go each and Every Folder and get the Files.
    
    If Subfolders = True Then
        For Each SubFolder In SourceFolder.Subfolders
            GetFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
    
    Set FileItem = Nothing
    Set SourceFolder = Nothing
End Sub

Как Applecore упомянул в комментариях ниже: Некоторое небольшое дополнительное ускорение может быть достигнуто путем определения большего массива в начале (например, 1000)

ReDim OutputArr(1 To 3, 1 To 1000)

, а затем изменяйте размер, только если этот предел 1000 было достигнуто

If c > 1000 Then ReDim Preserve OutputArr(1 To 3, 1 To c)

и, наконец, ограничьте действие записи в ячейку до c - 1, затем:

Range("A1").Resize(c - 1, UBound(OutputArr, 1)).Value = Application.WorksheetFunction.Transpose(OutputArr)