自适应的VBA Excel函数是递归的 [英] Adaptive a vba excel function to be recursive

问题描述

我无法将以目录文件夹为输入并将该文件夹中文件容器的文件名和其他文件属性输出到excel电子表格的工作解决方案转换为递归解决方案，该解决方案也输出子文件夹中包含的文件.我将不胜感激！

Im having trouble converting a working solution that takes a directory folder as an input and outputs the filenames and other file attributes of files container in the folder into an excel spreadsheet to a recursive solution that also outputs the files contained in subfolders. I would greatly appreciate any help!

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

推荐答案

我已经重写了代码，以将结果数组和一个计数器传递给递归函数.该函数将填充数组并使用任何子文件夹进行调用

I've rewritten the code to pass your results array and a counter to the recursive function. The function fills the array and calls itself with any subfolders

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

这篇关于自适应的VBA Excel函数是递归的的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！