Адаптивная функция vba excel для рекурсии

Question

У меня проблемы с преобразованием рабочего решения, которое принимает в качестве входной информации папку каталога и выводит имена файлов и другие атрибуты файлов контейнера файлов в папке в электронную таблицу Excel в рекурсивное решение, которое также выводит файлы, содержащиеся в подпапках.Буду очень признателен за любую помощь!

Sub GetFileList()

    Dim strFolder As String
    Dim varFileList As Variant
    Dim FSO As Object, myFile As Object
    Dim myResults As Variant
    Dim l As Long

    ' Get the directory from the user
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        'user cancelled
        strFolder = .SelectedItems(1)
    End With

    ' Get a list of all the files in this directory. ' Note that this isn't recursive... although it could be...
    varFileList = fcnGetFileList(strFolder)

    If Not IsArray(varFileList) Then
        MsgBox "No files found.", vbInformation
        Exit Sub
    End If

    ' Now let's get all the details for these files ' and place them into an array so it's quick to dump to XL.
    ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)

    ' place make some headers in the array
    myResults(0, 0) = "Filename"
    myResults(0, 1) = "Size"
    myResults(0, 2) = "Created"
    myResults(0, 3) = "Modified"
    myResults(0, 4) = "Accessed"
    myResults(0, 5) = "Full path"

    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Loop through our files
    For l = 0 To UBound(varFileList)
        Set myFile = FSO.GetFile(CStr(varFileList(l)))
        myResults(l + 1, 0) = CStr(varFileList(l))
        myResults(l + 1, 1) = myFile.Size
        myResults(l + 1, 2) = myFile.DateCreated
        myResults(l + 1, 3) = myFile.DateLastModified
        myResults(l + 1, 4) = myFile.DateLastAccessed
        myResults(l + 1, 5) = myFile.Path
    Next l

    ' Dump these to a worksheet
    fcnDumpToWorksheet myResults

    'tidy up
    Set myFile = Nothing
    Set FSO = Nothing

End Sub

Private Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant ' Returns a one dimensional array with filenames ' Otherwise returns False

    Dim f As String
    Dim i As Integer
    Dim FileList() As String

    If strFilter = "" Then strFilter = "."

    Select Case Right$(strPath, 1)
        Case "\", "/"
            strPath = Left$(strPath, Len(strPath) - 1)
    End Select

    ReDim Preserve FileList(0)

    f = Dir$(strPath & "\" & strFilter)
    Do While Len(f) > 0
        ReDim Preserve FileList(i) As String
        FileList(i) = f
        i = i + 1
        f = Dir$()
    Loop

    If FileList(0) <> Empty Then
        fcnGetFileList = FileList
    Else
        fcnGetFileList = False
    End If
End Function

Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)

    Dim iSheetsInNew As Integer
    Dim sh As Worksheet, wb As Workbook
    Dim myColumnHeaders() As String
    Dim l As Long, NoOfRows As Long

    If mySh Is Nothing Then
        'make a workbook if we didn't get a worksheet
        iSheetsInNew = Application.SheetsInNewWorkbook
        Application.SheetsInNewWorkbook = 1
        Set wb = Application.Workbooks.Add
        Application.SheetsInNewWorkbook = iSheetsInNew
        Set sh = wb.Sheets(1)
    Else
        Set mySh = sh
    End If

    With sh
        Range(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1)) = varData
        .UsedRange.Columns.AutoFit
    End With

    Set sh = Nothing
    Set wb = Nothing

End Sub

Answer 1

Я переписал код, чтобы передать массив результатов и счетчик в рекурсивную функцию. Функция заполняет массив и вызывает себя с любыми подпапками

Sub GetFileList()

    Dim strFolder As String
    Dim FSO As Object
    Dim fsoFolder As Object
    Dim myResults As Variant
    Dim lCount As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Get the directory from the user
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        'user cancelled
        strFolder = .SelectedItems(1)
    End With

    Set fsoFolder = FSO.GetFolder(strFolder)

    'the variable dimension has to be the second one
    ReDim myResults(0 To 5, 0 To 0)

    ' place make some headers in the array
    myResults(0, 0) = "Filename"
    myResults(1, 0) = "Size"
    myResults(2, 0) = "Created"
    myResults(3, 0) = "Modified"
    myResults(4, 0) = "Accessed"
    myResults(5, 0) = "Full path"

    'Send the folder to the recursive function
    FillFileList fsoFolder, myResults, lCount

    ' Dump these to a worksheet
    fcnDumpToWorksheet myResults

    'tidy up
    Set FSO = Nothing

End Sub

Private Sub FillFileList(fsoFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)

    Dim i As Integer
    Dim fsoFile As Object
    Dim fsoSubFolder As Object
    Dim fsoSubFolders As Object

    'load the array with all the files
    For Each fsoFile In fsoFolder.Files
        lCount = lCount + 1
        ReDim Preserve myResults(0 To 5, 0 To lCount)
        myResults(0, lCount) = fsoFile.Name
        myResults(1, lCount) = fsoFile.Size
        myResults(2, lCount) = fsoFile.DateCreated
        myResults(3, lCount) = fsoFile.DateLastModified
        myResults(4, lCount) = fsoFile.DateLastAccessed
        myResults(5, lCount) = fsoFile.Path
    Next fsoFile

    'recursively call this function with any subfolders
    Set fsoSubFolders = fsoFolder.SubFolders

    For Each fsoSubFolder In fsoSubFolders
        FillFileList fsoSubFolder, myResults, lCount
    Next fsoSubFolder

End Sub

Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)

    Dim iSheetsInNew As Integer
    Dim sh As Worksheet, wb As Workbook
    Dim myColumnHeaders() As String
    Dim l As Long, NoOfRows As Long

    If mySh Is Nothing Then
        'make a workbook if we didn't get a worksheet
        iSheetsInNew = Application.SheetsInNewWorkbook
        Application.SheetsInNewWorkbook = 1
        Set wb = Application.Workbooks.Add
        Application.SheetsInNewWorkbook = iSheetsInNew
        Set sh = wb.Sheets(1)
    Else
        Set mySh = sh
    End If

    'since we switched the array dimensions, have to transpose
    With sh
        Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
            Application.WorksheetFunction.Transpose(varData)

        .UsedRange.Columns.AutoFit
    End With

    Set sh = Nothing
    Set wb = Nothing

End Sub