performance – The best and most efficient way to browse files using Excel VBA


I have a procedure to browse all the files of folders and subfolders from a folder that the user can select. The user can select both source and target folders. I use Excel VBA for this. Spreadsheets contain all or some of the file names to look for.

It works like this. I have function GetFiles which returns a string (including the path) separated by a pipeline (|). Then, I browse all the cells in column A containing the file name (or part of it) to search for. the GetFiles browses all the folders and subfolders of the selected source path. It takes longer if a high level of the source folder is selected.

The main function looks like this:

Under MoveFilesToFolder ()

Dim filePath As String: filePath = ""
Dim moveToPath As String: moveToPath = ""
Dim filename as a 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 an integer
Sun J also long
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim result As String
Dim ws as sheet sheet
Dim frm As ufImageSearcher

ExactMatch = True
OverwriteExistingFile = False

Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error GoTo ErrorHandling

If (wsExists ("Images")) then

fileNameString = ""

& # 39; filePath = InputBox ("File Path, Close with Backslash ()", "Source Folder", ActiveWorkbook.Path)
& # 39; moveToPath = InputBox ("File copy path in! Close with backslash ()", "Target folder", ActiveWorkbook.Path & " copy ")

filePath = GetFolderPath ("Bron directory")
If (IsStringEmpty (filePath)) then
Output under
End if
moveToPath = GetFolderPath ("Doel directory")
If (IsStringEmpty (moveToPath)), then
Output under
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 the folder:" & moveToPath & "?", vbYesNo + vbQuestion, "Result!")
If (result = vbYes) Then
OpenFolderInExplorer (moveToPath)
End if
Output under
End if

wsActivate ("Images")
Set frm = New ufImageSearcher

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

If .Tag <> "Canceled" Then
ExactMatch = .cbxExactMatch.Value
OverwriteExistingFile = .cbxOverwrite.Value
Other
Output under
End if
Finish by

Start time = Timer

& # 39; Retrieves all files, including the path, separated by a pipeline.
GetFiles (filePath)

If not (IsStringEmpty (fileNameString)), then
Dim imgArray As Variant: imgArray = Split (fileNameString, "|")
& # 39; Column A contains all the strings used to compare the files found from the GetFiles function
For each cell in ActiveSheet.Range ("A1: A" & Range ("A1"). End (xlDown) .row)
Events
fileCopied = False
filename = Mid (cell.Value, lastpositionOfChar (cell.Value, "/") + 1, Len (cell.Value))

Application.StatusBar = "(File Nbr:" & CStr (UBound (imgArray)) & ")"


If not (IsStringEmpty (filename)), then
For i = LBound (imgArray) to UBound (imgArray)
Events
If not (IsStringEmpty (CStr (imgArray (i)))), then
If ExactMatch Then
If (GetFileName (imgArray (i)) = file name), then
If DoesFileExist (moveToPath & GetFileName (imgArray (i))) and do not overwrite the existing file
FileCopy imgArray (i), moveToPath & GetFileName (imgArray (i)) & "-" & Format (now, "yyyymmddhhmmss")
Other
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
Other
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
Other
If (InStr (1, GetFileName (imgArray (i)), filename, vbTextCompare)> 0), and then
If not (IsFileOpen (CStr (imgArray (i)))), then
If DoesFileExist (moveToPath & GetFileName (imgArray (i))) and do not overwrite the existing file
FileCopy imgArray (i), moveToPath & GetFileName (imgArray (i)) & "-" & Format (now, "yyyymmddhhmmss")
Other
FileCopy imgArray (i), moveToPath & GetFileName (imgArray (i))
End if
fileCopied = True

& # 39; Find the 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
Then I
If not copied then
ActiveSheet.Range ("B" & cell.row) .Value = "** NOT FOUND **"
ActiveSheet.Range ("B" & cell.row) .Font.Color = RGB (250, 0, 0)
End if
End if
following
End if

Sheets ("Images"). Columns ("B: Z"). Automatic adjustment
SecondsElapsed = Timer - Start Time

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 the folder:" & moveToPath & "?", vbYesNo + vbQuestion, "Result!"
If (result = vbYes) Then
OpenFolderInExplorer (moveToPath)
End if
Other

If not (FolderExists (filePath)) then
MsgBox (filePath & ": the path is niet gevonden!")
End if
If not (FolderExists (moveToPath)), then
MsgBox (moveToPath & ": Path is niet gevonden!")
End if
End if
Other
MsgBox ("No source and / or target selected" & vbCrLf & _
"Source:" & filePath & vbCrLf & _
"Target:" & moveToPath)
End if
Other
MsgBox ("This procedure expects a worksheet" Images & # 39; "& vbCrLf & _
"and the name or part of the name of the image to be found in column A")
End if
Completed:
If (IsObject (ws)) Then
Set ws = Nothing
End if

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Output under
Error handling:
MsgBox ("An error has occurred! (" & Err.Description & ")")
End Sub

The GetFiles function looks like:

Sub GetFiles (ByVal path as a string)

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

Dim subfolder as object
Dim file as object

For each subfolder in folder.SubFolders
Events
GetFiles (subfolder.path)
Subfolder next

For each file in folder.Files
fileNameString = fileNameString & file.path & "|"
Next file

Completed:
Set fso = Nothing
Define the folder = nothing
Set the subfolder = Nothing
Set file = Nothing

Output under

Error handling:
MsgBox ("An error has occurred! (" & Err.Description & ")")
End Sub

Everything works, but the execution can take a long time, especially when the selected source folder contains a lot of folders and subfolders.

To give you an idea, it takes 13 minutes to compare 100 rows of column A with 10 000 files found. The average loop 100 x 10,000 = 1 million times.

I have two questions:

  1. Is there a more efficient way to do this with Excel VBA?
  2. Is the DoEvents function used correctly?