excel - 更快地循环遍历文件夹、子文件夹并收集文件名+路径 VBA

Question

我尝试了一些代码，但它们运行速度太慢。我们的服务器中有大约50万个文件，我需要循环这些文件。结果就像 5 分钟内只有 3-4 k :) 也许你们知道如何更快地执行此代码循环？预先感谢您

Option Explicit
Sub getfiles()

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
    Dim i As Integer, colFolders As New Collection, ws As Worksheet, y As Integer
    
    Set ws = ActiveSheet
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder('my path)
    
    colFolders.Add oFolder
    
    DoEvents
    Do While colFolders.Count > 0
        Set oFolder = colFolders(1)
        colFolders.Remove 1
    
        For Each oFile In oFolder.Files
            If Right(oFile.Name, 4) = ".pdf" Then
                ws.Cells(i + 1, 1) = oFolder.Path
                ws.Cells(i + 1, 2) = oFile.Name
                i = i + 1
                y = y + 1
                If y = 2000 Then 'just saving to check result after few minutes with pause
                    ThisWorkbook.Save
                    Application.Wait (Now + TimeValue("0:00:10"))
                    y = 0
                End If
            End If
        Next oFile
        For Each sf In oFolder.SubFolders
            colFolders.Add sf
        Next sf
    Loop

End Sub

Answer 1

这应该更快:

Option Explicit

Sub getPdfFiles()
    Dim i As Long, ws As Worksheet
    Set ws = ActiveSheet
    
    Dim output As Object
    Set output = ShellOutput("Dir D:\BYoung\*.pdf /s /b /a:-d")
    
    Dim inLines() As String
    Dim sLine As String, lines As Long
    
    Do While Not output.AtEndOfStream
        sLine = output.ReadLine
    
        If Right(sLine, 4) = ".pdf" Then
            i = i + 1
            ReDim Preserve inLines(1 To i)
            inLines(i) = sLine
        End If
        'If i Mod 100 = 0 Then DoEvents
    Loop
    lines = i
    
    Dim fName As String, fFull As String, fPath As String
    Dim outLines As Variant
    ReDim outLines(1 To lines, 1 To 2)
    
    For i = 1 To lines
        fFull = inLines(i)
        fName = Right(fFull, Len(fFull) - InStrRev(fFull, "\"))
        fPath = Mid(fFull, 1, Len(fFull) - Len(fName))
        outLines(i, 1) = fPath
        outLines(i, 2) = fName
        'If i Mod 100 = 0 Then DoEvents
    Next i
    
    ws.Range("A1:B" & lines) = outLines
    
    ws.Parent.Save
End Sub

调用此函数:

' Create a Shell, executes a command, and returns the output stream
'(from @BrianBurns at https://stackoverflow.com/a/32600510/109122)
Public Function ShellOutput(sCmd As String) As Object
    Dim oShell As Object
    Set oShell = CreateObject("WScript.Shell")

    'run command
    Dim oExec As Object
    Dim oOutput As Object
    Set oExec = oShell.Exec("cmd.exe /c " & sCmd)
    Set oOutput = oExec.StdOut

    Set ShellOutput = oOutput
End Function