VBA macro that copy files from multiple subfolders - vba

Question

I have a VBA for copying images from one folder to another based on image names. You can check macro in work in attached. Code is:
Option Explicit
Sub CopyFiles()
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim bContinue As Boolean
bContinue = True
iRow = 2
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
sFileType = ".jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
' LOOP THROUGH COLUMN "A" TO PICK THE FILES.
While bContinue
If Len(Range("A" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Images have been moved. Thank you!" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.
If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("B" & CStr(iRow)).Value = "Does Not Exists"
Range("B" & CStr(iRow)).Font.Bold = True
Else
Range("B" & CStr(iRow)).Value = "On Hand"
Range("B" & CStr(iRow)).Font.Bold = False
If Trim(sDestinationPath) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")
' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDestinationPath) = False Then
MsgBox sDestinationPath & " Does Not Exists"
Exit Sub
End If
'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
However, I need 2 more things to add to this code:
When I enter the name of the file to be copied, I also want to copy
files that have the same name PLUS extension _01/_02/.../_07 if
those exist.
I want macro to look not only inside specified folder but also in
subfolders inside the folder and subfolders inside the subfolder
etc.
Can anyone help?
Thanks!

Answer 1

What you need is some Recursive Subs to find all the similar filenames based on the Range value.
Here I will approach this goal with below code with a couple of steps:
For each Range value (stored as a Key in Dictionary), find all the file names (exact and similar as Item in Dictionary). Joining each finding with "|" (an illegal file name character).
Process the Dictionary items after all files and sub folders from Source Path
For each Item in the dictionary of a key, see if existing file in destination folder. Append " (i)" to destination file name if already exists.
Copy the destination file to destination folder.
While copying, it returns the
Stop looping when first Empty cell is encountered
NOTE: Code not been tested, only compiled fine
Option Explicit
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
Private Const sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
Private Const sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
Private Const sFileType = "jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
Private Const DIV = "|" ' A character that's not legal file name
Private objFSO As Object, objDict As Object
Sub CopyFilesAlike()
Dim lRow As Long, sName As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(sSourcePath) Then
MsgBox "Source folder not found!" & vbCrLf & sSourcePath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
If Not objFSO.FolderExists(sDestinationPath) Then
MsgBox "Destination folder not found!" & vbCrLf & sDestinationPath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
' Proceed when both Source and Destination folders found
Set objDict = CreateObject("Scripting.Dictionary")
lRow = 2
Do Until IsEmpty(Cells(lRow, "A")) ' Stop on first empty cell in Column A from lRow
' Get Main file name to look up
sName = Cells(lRow, "A").Value
' Look for files (exact and alikes from sub folders) to add to dictionary
LookForFilesAlike sName, objFSO.GetFolder(sSourcePath)
' Copy files
If objDict.Count = 0 Then
Cells(lRow, "B").Value = "No files found."
Else
Cells(lRow, "B").Value = objDict.Count & " filenames(s) found." & vbLf & CopyFiles
End If
' Clear the Dictionary for next Name
objDict.RemoveAll
' Increment row counter
lRow = lRow + 1
Loop
Set objDict = Nothing
I_AM_DONE:
Set objFSO = Nothing
End Sub
Private Sub LookForFilesAlike(ByVal sName As String, ByVal objFDR As Object)
Dim oFile As Object, oFDR As Object
' Add files of current folder to dictionary if name matches
For Each oFile In objFDR.Files
If InStr(1, oFile.Name, sName, vbTextCompare) = 1 Then ' Names beginning with sName
' Check the extension to match
If LCase(objFSO.GetExtensionName(oFile)) = LCase(sFileType) Then
If objDict.Exists(oFile.Name) Then
' Append Path to existing entry
objDict.Item(oFile.Name) = objDict.Item(oFile.Name) & DIV & oFile.Path
Else
' Add Key and current path
objDict.Add oFile.Name, oFile.Path
End If
End If
End If
Next
' Recurse into each sub folder
For Each oFDR In objFDR.SubFolders
LookForFilesAlike sName, oFDR
Next
End Sub
Private Function CopyFiles() As String
Dim i As Long, oKeys As Variant, oItem As Variant, iRepeat As Integer, sName As String, sOut As String
sOut = ""
' Process the items for each key in Dictionary
Set oKeys = objDict.Keys ' <- Add "Set " before oKeys
For i = 0 To objDict.Count
For Each oItem In Split(objDict.Item(oKeys(i)), DIV)
' Determine the filename in destination path
If objFSO.FileExists(sDestinationPath & objFSO.GetFileName(oItem)) Then
' Same file name alreay found, try append " (i)"
iRepeat = 0
Do
iRepeat = iRepeat + 1
sName = objFSO.GetBaseName(oItem) & " (" & iRepeat & ")" & objFSO.GetExtensionName(oItem)
Loop While objFSO.FileExists(sDestinationPath & sName)
sName = sDestinationPath & sName
Else
' First file to be copied to destination folder
sName = sDestinationPath
End If
' Copy the source file to destination file
If Len(sOut) = 0 Then
sOut = oItem & DIV & sName
Else
sOut = sOut & vbLf & oItem & DIV & sName
End If
objFSO.CopyFile oItem, sName
Next
Next
CopyFiles = sOut
End Function