文件信息仅从子文件夹中提取仅2-3个级别

Question

i当前有一个代码，该代码将允许用户选择一个文件夹，然后该代码将在该文件夹中提取文件信息，而不是为子文件夹中的任何文件。我有7个级别的子文件夹，其中包含约140,000个文件。我想知道我是否有一种方法只能拉出子文件夹级别2-3中的文件信息，而不是从所有7个级别中。谢谢您的帮助。

我认为"第3列中的粘贴公式"部分与此问题无关。

可能重要的部分是"选择一个文件夹"one_answers"通过所选文件夹中的每个文件运行"

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

Answer 1

我修改了您的代码以使用数组，并使用递归功能返回文件夹文件信息。

---

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

Answer 2

文件系统对象可以为您执行此操作。

在此示例中，代码返回C： drive。

上的每个子文件夹。

' 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窗口打开（ view >> 立即窗口）。

要使用文件系统对象，您需要添加参考（ tools >> 参考>>>> 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