从仅 2-3 层深的子文件夹中提取文件信息
File info pull from sub folders only 2-3 levels deep
我目前有一个代码允许用户选择一个文件夹，然后该代码将提取该文件夹中文件的文件信息，但不提取子文件夹中任何文件的文件信息。我有 7 级子文件夹，其中包含大约 140,000 个文件。我想知道是否有一种方法可以让我只提取 2-3 级子文件夹中的文件信息，而不仅仅是 1 级，而不是来自所有 7 级。感谢您的帮助。
我认为 "pasting formula in column 3" 部分与此问题无关。
可能重要的部分是 "Picking a folder" 和 "Running through each file in the selected folder"
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:$B,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
file system object 可以为您做到这一点。
在此示例中，代码 returns 您 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 window（查看 >> 立即Window).
要使用文件系统对象，您需要添加引用 (Tools >> References >> 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
我修改了您的代码以使用数组并使用递归函数return 文件夹文件信息。
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:$B,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
我目前有一个代码允许用户选择一个文件夹，然后该代码将提取该文件夹中文件的文件信息，但不提取子文件夹中任何文件的文件信息。我有 7 级子文件夹，其中包含大约 140,000 个文件。我想知道是否有一种方法可以让我只提取 2-3 级子文件夹中的文件信息，而不仅仅是 1 级，而不是来自所有 7 级。感谢您的帮助。
我认为 "pasting formula in column 3" 部分与此问题无关。
可能重要的部分是 "Picking a folder" 和 "Running through each file in the selected folder"
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:$B,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
file system object 可以为您做到这一点。
在此示例中，代码 returns 您 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 window（查看 >> 立即Window).
要使用文件系统对象，您需要添加引用 (Tools >> References >> 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
我修改了您的代码以使用数组并使用递归函数return 文件夹文件信息。
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:$B,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