5
\$\begingroup\$

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?
\$\endgroup\$
3
  • \$\begingroup\$ 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. \$\endgroup\$ Commented Mar 23, 2020 at 15:19
  • 1
    \$\begingroup\$ 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 \$\endgroup\$ Commented Mar 23, 2020 at 15:24
  • \$\begingroup\$ 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. \$\endgroup\$ Commented Mar 24, 2020 at 16:37

1 Answer 1

Reset to default
5
\$\begingroup\$

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
\$\endgroup\$
5
  • \$\begingroup\$ 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. \$\endgroup\$ Commented Jun 13, 2019 at 7:42
  • \$\begingroup\$ 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. \$\endgroup\$ Commented Jun 13, 2019 at 12:34
  • 1
    \$\begingroup\$ 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. \$\endgroup\$ Commented Jun 13, 2019 at 13:26
  • 1
    \$\begingroup\$ But is it good thinking. I like it. I'm no Guru either. And this is my first code review. Learning every day. ;-) \$\endgroup\$ Commented Jun 13, 2019 at 14:14
  • 1
    \$\begingroup\$ DNRY is more commonly known as DRY: Do Not Repeat Yourself or Don't Repeat Yourself. It's anti-WET: Write Everything Twice. \$\endgroup\$ Commented Mar 5, 2020 at 13:55

You must log in to answer this question.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.