gpt4 book ai didi

recursion - 自适应vba excel函数递归

转载 作者:行者123 更新时间:2023-12-04 20:20:29 26 4
gpt4 key购买 nike

我无法将一个以目录文件夹作为输入并将文件夹中文件容器的文件名和其他文件属性输出到 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

最佳答案

我重写了代码以将您的结果数组和一个计数器传递给递归函数。该函数填充数组并使用任何子文件夹调用自身

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

关于recursion - 自适应vba excel函数递归,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/4170794/

26 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com