Most efficient way to loop through files using VBA Excel

Question

I have a procedure for looping through all files in folders and subfolders starting at a folder which the user can select. The user can select both the source and target folder. I'm using Excel VBA for this. The worksheets contain all the files names or part of it, to search for.

It works like this. I have function GetFiles which returns a string (including the path) separated by a pipeline (|). Then I loop through all the cells in column A which contains the filename (or part of it) to search for. The GetFiles loops through all the folders and subfolders from the selected Source path. This takes longer if a High level of the source folder is selected.

The main function looks like this:

Sub MoveFilesToFolder()

    Dim filePath As String: filePath = ""
    Dim moveToPath As String: moveToPath = ""
    Dim filename As String
    Dim fileNameFront As String
    Dim fileNameRear As String
    Dim currentFileName As String
    Dim cell   As Range
    Dim fileCopied As Boolean: fileCopied = False
    Dim i      As Integer
    Dim J      As Long
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim result As String
    Dim ws     As Worksheet
    Dim frm    As ufImageSearcher

    ExactMatch = True
    OverwriteExistingFile = False

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    On Error GoTo ErrorHandling

    If (wsExists("Images")) Then

        fileNameString = ""

        'filePath = InputBox("Path to the files, close with backslash (\)", "Source folder", ActiveWorkbook.Path)
        'moveToPath = InputBox("Path to copy files to! Close with backslash (\)", "Target folder", ActiveWorkbook.Path & "\copy\")

        filePath = GetFolderPath("Bron directory")
        If (IsStringEmpty(filePath)) Then
            Exit Sub
        End If
        moveToPath = GetFolderPath("Doel directory")
        If (IsStringEmpty(moveToPath)) Then
            Exit Sub
        End If

        If Not (IsStringEmpty(filePath) Or IsStringEmpty(moveToPath)) Then

            If ((FolderExists(filePath)) And _
               (FolderExists(moveToPath))) And (filePath <> moveToPath) Then

            If Right(moveToPath, 1) <> "\" Then
                moveToPath = moveToPath & "\"
            End If

            If (Dir(moveToPath & "*.*") <> "") Then
                result = MsgBox(moveToPath & " contains files! Choose an empty folder!" & _
                         vbCrLf & vbCrLf & "Go to folder: " & moveToPath & "?", vbYesNo + vbQuestion, "Result!")
                If (result = vbYes) Then
                    OpenFolderInExplorer (moveToPath)
                End If
                Exit Sub
            End If

            wsActivate ("Images")
            Set frm = New ufImageSearcher

            With frm
                .lblSource.Caption = filePath
                .lblTarget.Caption = moveToPath
                .Show

                If .Tag <> "Canceled" Then
                    ExactMatch = .cbxExactMatch.Value
                    OverwriteExistingFile = .cbxOverwrite.Value
                Else
                    Exit Sub
                End If
            End With

            StartTime = Timer

            'Get all files, including the path, seperated with a pipeline.
            GetFiles (filePath)

            If Not (IsStringEmpty(fileNameString)) Then
                Dim imgArray As Variant: imgArray = Split(fileNameString, "|")
                'Column A contains all strings which are used to compare to the found files from the GetFiles-function  
                For Each cell In ActiveSheet.Range("A1:A" & Range("A1").End(xlDown).row)
                    DoEvents
                    fileCopied = False
                    filename = Mid(cell.Value, lastpositionOfChar(cell.Value, "/") + 1, Len(cell.Value))

                    Application.StatusBar = "(Nr. of files:" & CStr(UBound(imgArray)) & ")"


                    If Not (IsStringEmpty(filename)) Then
                        For i = LBound(imgArray) To UBound(imgArray)
                            DoEvents
                            If Not (IsStringEmpty(CStr(imgArray(i)))) Then
                                If ExactMatch Then
                                    If (GetFileName(imgArray(i)) = filename) Then
                                        If DoesFileExist(moveToPath & GetFileName(imgArray(i))) And Not OverwriteExistingFile Then
                                            FileCopy imgArray(i), moveToPath & GetFileName(imgArray(i)) & "-" & Format(Now, "yyyymmddhhmmss")
                                        Else
                                            FileCopy imgArray(i), moveToPath & GetFileName(imgArray(i))
                                        End If
                                        fileCopied = True

                                        If fileCopied Then
                                            ActiveSheet.Range("B" & cell.row).Value = imgArray(i)

                                            For J = 2 To 15
                                                Dim newFileName As String
                                                newFileName = CreateFileName(CStr(imgArray(i)), LeadingZeroString(J))
                                                If Not (IsStringEmpty(newFileName)) Then
                                                    If (DoesFileExist(newFileName)) Then
                                                        If Not (IsFileOpen(newFileName)) Then
                                                            FileCopy newFileName, moveToPath & Right(newFileName, Len(newFileName) - lastpositionOfChar(newFileName, "\") + 1)
                                                            ActiveSheet.Range(GetColLetter(J + 1) & cell.row).Value = newFileName
                                                            ActiveSheet.Range(GetColLetter(J + 1) & cell.row).Font.Color = RGB(0, 102, 0)
                                                        End If
                                                    Else
                                                        ActiveSheet.Range(GetColLetter(J + 1) & cell.row).Value = "(Niet aanwezig) " & Right(newFileName, Len(newFileName) - lastpositionOfChar(newFileName, "\") + 1)
                                                        ActiveSheet.Range(GetColLetter(J + 1) & cell.row).Font.Color = RGB(255, 153, 51)
                                                    End If
                                                End If
                                            Next J
                                        End If
                                    End If
                                Else
                                    If (InStr(1, GetFileName(imgArray(i)), filename, vbTextCompare) > 0) Then
                                        If Not (IsFileOpen(CStr(imgArray(i)))) Then
                                            If DoesFileExist(moveToPath & GetFileName(imgArray(i))) And Not OverwriteExistingFile Then
                                                FileCopy imgArray(i), moveToPath & GetFileName(imgArray(i)) & "-" & Format(Now, "yyyymmddhhmmss")
                                            Else
                                                FileCopy imgArray(i), moveToPath & GetFileName(imgArray(i))
                                            End If
                                            fileCopied = True

                                            'Find first empty columnid.

                                            lCol = Cells(cell.row, Columns.Count).End(xlToLeft).Column
                                            ActiveSheet.Cells(cell.row, lCol + 1).Value = imgArray(i)
                                        End If
                                    End If

                                End If
                            End If
                        Next i
                        If Not fileCopied Then
                            ActiveSheet.Range("B" & cell.row).Value = "** NOT FOUND **"
                            ActiveSheet.Range("B" & cell.row).Font.Color = RGB(250, 0, 0)
                        End If
                    End If
                Next
            End If

            Worksheets("Images").Columns("B:Z").AutoFit
            SecondsElapsed = Timer - StartTime

            Application.DisplayAlerts = True
            Application.ScreenUpdating = True

            result = MsgBox("Date Exported in: " & moveToPath & vbCrLf & "This was done in: " & Format(SecondsElapsed / 86400, "hh:mm:ss") & " seconds." & _
                     vbCrLf & vbCrLf & "Go to folder: " & moveToPath & "?", vbYesNo + vbQuestion, "Resultaat!")
            If (result = vbYes) Then
                OpenFolderInExplorer (moveToPath)
            End If
        Else

            If Not (FolderExists(filePath)) Then
                MsgBox (filePath & ": Path is niet gevonden!")
            End If
            If Not (FolderExists(moveToPath)) Then
                MsgBox (moveToPath & ": Path is niet gevonden!")
            End If
        End If
    Else
        MsgBox ("No Source and/or Target selected" & vbCrLf & _
               "Source: " & filePath & vbCrLf & _
               "Target: " & moveToPath)
    End If
Else
    MsgBox ("This procedure expect a worksheet 'Images' " & vbCrLf & _
           "and the name or part of the name of the image to find in column A")
End If
Done:
    If (IsObject(ws)) Then
        Set ws = Nothing
    End If

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub
ErrorHandling:
    MsgBox ("Something went wrong!(" & err.Description & ")")
End Sub

The GetFiles function looks like:

Sub GetFiles(ByVal path As String)

    On Error GoTo ErrorHandling
    Dim fso    As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim folder As Object: Set folder = fso.GetFolder(path)

    Dim subfolder As Object
    Dim file   As Object

    For Each subfolder In folder.SubFolders
        DoEvents
        GetFiles (subfolder.path)
    Next subfolder

    For Each file In folder.Files
        fileNameString = fileNameString & file.path & "|"
    Next file

Done:
    Set fso = Nothing
    Set folder = Nothing
    Set subfolder = Nothing
    Set file = Nothing

    Exit Sub

ErrorHandling:
    MsgBox ("Something went wrong!(" & err.Description & ")")
End Sub

It all works, but it takes a long time to run, especially when there are a lot of folders and subfolders under the selected source folder.

To give you an idea, the procedure takes 13 minutes to compare 100 rows in column A against 10.000 files found. The means it loops 100 x 10.000 = 1milion times.

I have two questions:

1. Is there a more efficient way of doing this using Excel VBA?
2. Is the DoEvents function used in the correct way?

Answer 1

MoveFilesToFolder()

MoveFilesToFolder() is doing too much.

Testing filePath and moveToPath in a separate sub would greatly reduce MoveFilesToFolder() size making it easier to read, test and modify.

Private Const DirctoryBron As String = "Bron directory"
Private Const DirctoryDoel As String = "Doel directory"
Private Const WorksheetImages As String = "Images"

Sub Main()
    Dim filePath As String, moveToPath As String
    
    If Not (wsExists(WorksheetImages)) Then
        MsgBox WorksheetImages & " worksheet not found"
    Else
        filePath = GetFolderPath(DirctoryBron)
        If Len(filePath) > 0 And Not IsStringEmpty(filePath) Then
            moveToPath = GetFolderPath(DirctoryDoel)
            If Len(moveToPath) > 0 Then
                MoveFilesToFolder filePath, moveToPath
            End If
        End If
    End If
    
End Sub

Function GetFolderPath(ByVal SubFolderName As String)
    Dim filePath As String
   '..... Some Code...
    
    If Len(Dir(filePath, vbDirectory)) = 0 Then
        MsgBox (filePath & ": Path is niet gevonden!")
    Else
        GetFolderPath = filePath
    End If
End Function

Sub MoveFilesToFolder(filePath As String, moveToPath As String)
    '..... Some Code...
End Sub

Function IsStringEmpty(filePath As String) As Boolean
    If Len(Dir(filePath)) = 0 Then
        MsgBox filePath & " has no files"
        IsStringEmpty = True
    End If
End Function

GetFiles()

fileNameString should not be a global variable. It is a best practice to avoid global variables whenever possible. The name GetFiles() implies that it is a function ans it should be a function.
A single FileSystemObject is being created every time GetFiles() is getting called. It is better to create a single instance of the FileSystemObject and pass it as a parameter.

Function GetFiles(ByVal path As String, Optional fso As Object) As String
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")

The main reason that GetFiles() is so slow is string concatenation is inefficient. Everytime a string is concatenated a new string variable is created. Let's say that the average file path is 50 bytes long. After 2K files, fileNameString would be 100K bytes and by the time we reach the 10K fileNameString would be 500k bytes. Creatin an array of filename and using Join() to concatenate the array would be much faster.

An easier solution is to use WScript.Shell to return filenames:

Function GetFiles(ByVal rootPath As String) As Variant
    Dim result As String
    result = CreateObject("WScript.Shell").exec("cmd /c dir """ & rootPath & """ /a:d-h-s /b /s").StdOut.ReadAll
    result = Left(result, Len(result) - 2)
    result = Replace(result, vbNewLine, "|")
    GetFiles = result
End Function

For faster lookups I would add the file paths to a dictionary.

Function GetFileMap(ByVal rootPath As String) As Scripting.Dictionary
    Dim map As New Scripting.Dictionary
    Dim key
    
    Dim result As String
    result = CreateObject("WScript.Shell").exec("cmd /c dir """ & rootPath & """ /a:d-h-s /b /s").StdOut.ReadAll
    
    For Each key In Split(result, vbNewLine)
        If Len(key) > 0 Then
            map.Add key, vbNullString
        End If
    Next
    
    Set GetFileMap = map
End Function

Addendum

I didn't elaborate much on using a dictionary but it is much faster than looping over all the cells for each item in the file array. It looks like you would need to have the file name for the dictionary keys and the file paths for the the dictionary values.

I personally don't like GetColLetter(). I can see where it my be handy for creating cell formulas but there is always another way when working with ranges.

I'm not a fan of creating functions to that basically rename built-in functions. In this project lastpositionOfChar() was used instead Instr(). 2 years from now you might forget lastpositionOfChar() and write lastCharPosition(). It also makes code reuse more difficult because you created a dependency on another function.

 filename = Mid(cell.Value, lastpositionOfChar(cell.Value, "/") + 1, Len(cell.Value))

Len(cell.Value) is not needed. I prefer filename = Mid(cell.Value, InStrRev(cell.Value, "/")).

LeadingZeroString() I would use a public Const to store the number format.

Public Const LeadingZero As String = "000"

Although you have done an outstanding job of naming your custom functions I would still use the built-in ones.

Here is a small sample of how I would refactor the code:

Before

If fileCopied Then
    ActiveSheet.Range("B" & cell.Row).Value = imgArray(i)

    For J = 2 To 15
        Dim newFileName As String
        newFileName = CreateFileName(CStr(imgArray(i)), LeadingZeroString(J))
        If Not (IsStringEmpty(newFileName)) Then
            If (DoesFileExist(newFileName)) Then
                If Not (IsFileOpen(newFileName)) Then
                    FileCopy newFileName, moveToPath & Right(newFileName, Len(newFileName) - lastpositionOfChar(newFileName, "\") + 1)
                    ActiveSheet.Range(GetColLetter(J + 1) & cell.Row).Value = newFileName
                    ActiveSheet.Range(GetColLetter(J + 1) & cell.Row).Font.Color = RGB(0, 102, 0)
                End If
            Else
                ActiveSheet.Range(GetColLetter(J + 1) & cell.Row).Value = "(Niet aanwezig) " & Right(newFileName, Len(newFileName) - lastpositionOfChar(newFileName, "\") + 1)
                ActiveSheet.Range(GetColLetter(J + 1) & cell.Row).Font.Color = RGB(255, 153, 51)
            End If
        End If
    Next J
End If

After

If fileCopied Then
    cell.EntireColumn.Columns("B").Value = imgArray(i)

    For J = 2 To 15
        Dim newFileName As String
        newFileName = CreateFileName(CStr(imgArray(i)), Format(J, LeadingZero))
        If Len(newFileName) > 0 Then
            If Len(Dir(newFileName)) > 0 Then
                If Not (IsFileOpen(newFileName)) Then
                    FileCopy newFileName, moveToPath & Right(newFileName, Len(newFileName) - InStrRev(newFileName, "\") + 1)
                    cell.Offset(0, J).Value = newFileName
                    cell.Offset(0, J).Font.Color = RGB(0, 102, 0)
                End If
            Else
                cell.Offset(0, J).Value = "(Niet aanwezig) " & Right(newFileName, Len(newFileName) - InStrRev(newFileName, "\") + 1)
                cell.Offset(0, J).Font.Color = RGB(255, 153, 51)
            End If
        End If
    Next J
End If