我目前有一个允许用户选择文件夹的代码，然后代码将提取该文件夹中文件的文件信息，但不会提取子文件夹中的任何文件。我有7个级别的子文件夹，包含大约140,000个文件。我想知道是否有一种方法让我只拉取子文件夹级别2-3中的文件信息而不仅仅是1而不是所有7级别。谢谢你的帮助。
我不认为第3栏中的“粘贴公式”部分与此问题相关。
可能重要的部分是“挑选文件夹”和“运行所选文件夹中的每个文件”
Sub Compile3()
Dim oShell As Object
Dim oFile As Object
Dim oFldr As Object
Dim lRow As Long
Dim iCol As Integer
Dim vArray As Variant
vArray = Array(10, 0, 1, 156, 2, 4, 144, 146, 183, 185)
Set oShell = CreateObject("Shell.Application")
Dim iRow As Long
iRow = Cells.find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
lRow = iRow
'----------------------Picking a folder-------------------------------------
With Application.FileDialog(msoFileDialogFolderPicker)
.title = "Select the Folder..."
If .Show Then
Set oFldr = oShell.Namespace(.SelectedItems(1))
With oFldr
'Don't show update on the screen until the macro is finished
Application.EnableEvents = False
'---------------Column header information-----------------------------------
For iCol = LBound(vArray) To UBound(vArray)
If lRow = 2 Then
Cells(lRow, iCol + 4) = .getdetailsof(.items, vArray(iCol))
Else
Cells(lRow, iCol + 4) = "..."
End If
Next iCol
'---------------Running through each file in the selected folder------------
For Each oFile In .items
lRow = lRow + 1
For iCol = LBound(vArray) To UBound(vArray)
Cells(lRow, iCol + 4) = .getdetailsof(oFile, vArray(iCol))
Next iCol
' ---------------Pasting formula in column 3 -----------------------------
If lRow < 4 Then
Cells(lRow, 3).Formula = "=IFERROR(VLOOKUP(D3,$A$3:$B$10,2,FALSE),""User Not Found"")"
Else
Cells((lRow - 1), 3).Copy
Cells(lRow, 3).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells(lRow, 3).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
'------------------------------------------------------------------------------
Next oFile
End With
End If
Application.EnableEvents = True
End With
End Sub
答案 0 :(得分：0)
file system object可以为您做到这一点。
在此示例中，代码返回C：\驱动器上的每个子文件夹。
' Returns every folder under the C:\.
Sub CrawlFolder()
Dim fso As FileSystemObject ' Access the Windows file system.
Dim folder As folder ' Used to loop over folders.
Set fso = New FileSystemObject
For Each folder In fso.GetFolder("C:\").SubFolders
Debug.Print folder.Name
Next
End Sub
要查看结果，请确保您已打开Immediate窗口（查看＆gt;＆gt; 立即窗口）。
要使用文件系统对象，您需要添加引用（工具＆gt;＆gt; 参考＆gt;＆gt; Windows脚本宿主对象模型）。
您可以添加第二个For Each Loop来查看文件：
' Returns every folder under the C:\.
Sub CrawlFolder()
Dim fso As FileSystemObject ' Access the Windows file system.
Dim folder As folder ' Used to loop over folders.
Dim file As file ' Used to loop over files.
Set fso = New FileSystemObject
For Each folder In fso.GetFolder("C:\").SubFolders
For Each file In folder.Files
Debug.Print file.Name
Next
Next
End Sub
答案 1 :(得分：0)
我修改了你的代码以使用数组并使用递归函数来返回文件夹文件信息。
Sub ProcessFolder()
Dim FolderPath As String
Dim results As Variant
Dim Target As Range
FolderPath = getFileDialogFolder
If Len(FolderPath) = 0 Then Exit Sub
getFolderItems FolderPath, results
CompactResults results
With Worksheets("Sheet1")
.Range("C3", .Range("I" & Rows.Count).End(xlUp)).ClearContents
Set Target = .Range("C3")
Set Target = Target.EntireRow.Cells(1, 4)
Target.Resize(UBound(results), UBound(results, 2)).Value = results
Target.Offset(1, -1).Resize(UBound(results) - 1).Formula = "=IFERROR(VLOOKUP(D3,$A$3:$B$10,2,FALSE),""User Not Found"")"
End With
End Sub
Sub CompactResults(ByRef results As Variant)
Dim data As Variant
Dim x As Long, x1 As Long, y As Long, y1 As Long
ReDim data(1 To UBound(results) + 1, 1 To UBound(results(0)) + 1)
For x = LBound(results) To UBound(results)
x1 = x1 + 1
y1 = 0
For y = LBound(results(x)) To UBound(results(x))
y1 = y1 + 1
data(x1, y1) = results(x)(y)
Next
Next
results = data
End Sub
Function getFileDialogFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the Folder..."
.AllowMultiSelect = False
If .Show Then
getFileDialogFolder = .SelectedItems(1)
End If
End With
End Function
Sub getFolderItems(FolderPath As String, ByRef results As Variant, Optional MaxLevels As Long = 1, Optional oShell As Object, Optional Level As Long)
Dim oFile As Object, oFldr As Object
If oShell Is Nothing Then
ReDim results(0)
Set oShell = CreateObject("Shell.Application")
End If
If Not IsEmpty(results(UBound(results))) Then ReDim Preserve results(UBound(results) + 1)
Set oFldr = oShell.Namespace(CStr(FolderPath))
results(UBound(results)) = getFolderFileDetailArray(oFldr.Self, oFldr)
results(UBound(results))(1) = oFldr.Self.Path
For Each oFile In oFldr.Items
ReDim Preserve results(UBound(results) + 1)
If oFldr.getDetailsOf(oFile, 2) = "File folder" Then
If Level < MaxLevels Then
getFolderItems oFile.Path, results, MaxLevels, oShell, Level + 1
End If
End If
results(UBound(results)) = getFolderFileDetailArray(oFile, oFldr)
Next oFile
End Sub
Function getFolderFileDetailArray(obj As Object, oFldr As Object) As Variant
Dim iCol As Integer
Dim vDetailSettings As Variant
vDetailSettings = Array(10, 0, 1, 156, 2, 4, 144, 146, 183, 185)
For iCol = LBound(vDetailSettings) To UBound(vDetailSettings)
vDetailSettings(iCol) = oFldr.getDetailsOf(obj, vDetailSettings(iCol))
Next iCol
getFolderFileDetailArray = vDetailSettings
End Function