从子文件夹中提取的文件信息只有 2-3 级

Question

我目前有一个代码允许用户选择一个文件夹，然后该代码将提取该文件夹中文件的文件信息，但不会提取子文件夹中的任何文件。我有 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

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

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 窗口（查看 >> 即时窗口）。

要使用文件系统对象，您需要添加一个引用（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