i tryed few codes, but they works too slow. We have like half million files in server which i need to loop. And result is like only 3-4 k in 5 mins :) Maybe you guys idea how to do this code loop faster? thank you in advance

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

CodePudding user response：

This should be faster:

Option Explicit

Sub getPdfFiles()
    'perf question from https://stackoverflow.com/questions/70304602/loop-faster-through-folders-subfolders-and-collect-file-namespath-vba
'    Dim startTime As Date: startTime = Now()
'    Debug.Print "start: " & Format(startTime, "hh:mm:ss")
    
    Dim i As Integer, ws As Worksheet, y As Integer
    
    Set ws = ActiveSheet
    
    Dim output As Object
    Set output = ShellOutput("Dir D:\BYoung\*.pdf /s /b")
    
    Dim inLines() As String
    ReDim inLines(1 To 1)
    Dim sLine As String, lines As Long
    
    DoEvents
    Do While Not output.AtEndOfStream
        sLine = output.ReadLine
    
        If Right(sLine, 4) = ".pdf" Then
            ReDim Preserve inLines(1 To i   1)
            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
    
    ThisWorkbook.Save
    
    'Dim doneTime As Date: doneTime = Now()
    'Debug.Print "done: " & Format(doneTime, "hh:mm:ss")
End Sub

Which calls this function:

' Create a Shell, executes a command, and returns the output stream
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

CodePudding user response：

Another option using Dir() for files:

Sub Tester()
   Dim matches As Collection
   
   Set matches = GetMatches("C:\Test", "*.pdf")

   'loop matches and list file info...
    
End Sub


'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr, fpath
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
        
        fpath = fldr.Path
        If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
        f = Dir(fpath & filePattern)'Dir is faster...
        Do While Len(f) > 0
            colFiles.Add fso.getfile(fpath & f)
            f = Dir()
        Loop
    Loop
    Set GetMatches = colFiles
End Function