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?

• Mast: Please do not update the code in your question to incorporate feedback from answers, doing so goes against the Question + Answer style of Code Review. This is not a forum where you should keep the most updated version in your question. Please see what you may and may not do after receiving answers .
• Sᴀᴍ Onᴇᴌᴀ: I have rolled back Rev 7 → 4. Please see What to do when someone answers. Protip: you might be able to gain more reputation score if you opt for option 1 or 2
• Stephan: This was not an update off code, but adding a piece of code which was missing in the total answer. It is more complete now. It does not influence the answer.

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

• Stephan: Totally agree on making it better readable. I like your suggestions and improvement. Thank you for that. Now that you mentioned the concatenation thing, I do remember reading about it. I will adjust the code. Thanks again.
• Stephan: I see your point. And I must admit, I often forget about functions I wrote before, doing the whole thing again. Totally against the D.N.R.Y.. Selecting the file infor using the CMD command is superfast indeed.
• TinMan: D.N.R.Y? Dictionary? You have a nice coding style, It is really easy to follow. Keep in mind that my review is just my opinion. I am by no means a guru.
• Stephan: But is it good thinking. I like it. I'm no Guru either. And this is my first code review. Learning every day. ;-)
• Mast: DNRY is more commonly known as DRY: Do Not Repeat Yourself or Don't Repeat Yourself. It's anti-WET: Write Everything Twice.