When managing projects I use a few different off-the-shelf products. But, it always seems there is some task I need to do that can’t be done efficiently with these tools so I make sure to include MS Excel (Office 365) in my suite of project management utilities. VBA macros within Excel give me the power to complete any custom tasks I require.
I needed to copy a set of folders (an entire recursive tree) to a new location. VBA does not natively include this feature. I searched the web for solutions but it seemed all were either out-of-date (non functional) or simply incomplete (never worked!). So, I thought I’d share my solution built on the VBA scripting.filesystemobject. Hopefully it will help others. Here it is …
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | Public Sub TestCopyFiles() ' Call the recursive copy operation CopyFiles "c:\temp\a", "c:\temp\b"End SubPublic Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String, Optional ByVal basePath As String, Optional ByVal baseTarget As String) If basePath = "" Then basePath = strPath If baseTarget = "" Then baseTarget = strTarget Set FSO = CreateObject("scripting.filesystemobject") ' First loop through files in this folder For Each nextFile In FSO.getfolder(strPath).Files fullTargetPath = strTarget + "\" + nextFile.Name mkdir (strTarget) ' Copy one file FileInFromFolder.Copy fullTargetPath Next ' Next loop through folders in this folder For Each nextFolder In FSO.getfolder(strPath).SubFolders nextStrTarget = baseTarget + Right(nextFolder, Len(nextFolder) - Len(basePath)) mkdir (nextStrTarget) CopyFiles nextFolder.Path, nextStrTarget, basePath, baseTarget NextEnd SubPrivate Sub mkdir(folder As String) ' Create a folder if it doesn't exist Set FSO = CreateObject("scripting.filesystemobject") On Error Resume Next FSO.CreateFolder (folder) On Error GoTo 0End Sub |