Copy matching files/folders (using unique ID) from one directory to another

Good morning all,

Hopefully my question title was not too vague, however please let me explain the issue in more detail...

I have two directories, both with many subfolders, with each of these subfolders being assigned a unique ID reference number and containing an Excel file with the same corresponding ID number. Some of the Excel files do not belong to a subfolder and are placed directly into the parent folder. To clarify, please find an example below;


Main (Parent) Folders ---- Subfolder ---- File(s)

Finance ---- 5000 ---- 5000 - Financev1.xlsx
Management ---- 5001 ---- 5001 - Mangementv1.xlsx
Customer Service ---- 5002 ---- 5002 - CustServicev1.xlsx

Example path: C:\My Documents\Finance\5000\5000-Financev1.xlsx

To make matters more confusing, many of these type of files are on another drive (Z:\) and have been incorrectly named/filed (although generally always including their respective 4 digit ID reference in the title) and therefore the search must sometimes only look up a portion of the filename.

I have unfortunately been tasked with copying all of the folders containing the Excel files from Z:\ to C:\ while keeping all of the files contained in each folder.

The folders containing the Excel files already exist on the Z:\ drive while an empty folder of the same name already exists on the C:\ drive - the lookup must therefore look through all of the folders on the Z:\ drive and, if the folder/file matches the corresponding folder name on the C:\ drive, then make a copy of it while keeping any subfolders/files in place. It should also preferably not delete, overwrite or remove any files.

If anyone could help me out with this, I'd be extremely grateful. I'm very new to VBA and have done many searches on the internet for what I am looking for, but unfortunately have been unable to successfully implement any of the codes I have found. If anyone requires additional clarification on any of the above, please let me know and I will try to provide a clear explanation.

Thank you all in advance.

Tom

How many files are there in the Z drive folder that don't need copying? If it's not too many, and all of the files start with the 4 digit ID I would approach this by first copying the whole folder from Z to C and then searching for all files in the folder on C drive. Sort by name and you should get all the files with numbers at the top.

It's probably easier to copy the files across and delete the ones you don't want with VBA for what it's worth, then you don't need to deal with creating the subfolder structure and can just cycle through all the files/folders and look at each filename.

It would help if you could provide a bigger list of example filenames, especially if they are incorrectly named/filed to work out what the condition needs to be to filter out the files.

If it's any help, I made this macro to copy my outlook folder structure and files to a network drive, which isn't too disimilar to what you are looking to do:

Sub Mail_Backup()

Dim namespc, Archive_In, Archive_Out, Backup_Folder, fs, f

Set namespc = Application.GetNamespace("MAPI")
Set Archive_In = namespc.Folders("Archive (In)")
Set Archive_Out = namespc.Folders("Archive (Out)")
Set fs = CreateObject("scripting.filesystemobject")
Set Backup_Folder = fs.createfolder("R:\Acoustics\J. Hill\Mail Backup " & Strings.Left(Now, 2) & " " & Strings.Mid(Now, 4, 2) & " " & Strings.Mid(Now, 9, 2) & " " & Strings.Mid(Now, 12, 2) & " " & Strings.Mid(Now, 15, 2) & " " & Strings.Mid(Now, 18, 2))
fs.createfolder (Backup_Folder & "\" & "Archive In")
fs.createfolder (Backup_Folder & "\" & "Archive Out")

Call Create_Backup(Backup_Folder & "\" & "Archive In", Archive_In, fs)
Call Create_Backup(Backup_Folder & "\" & "Archive Out", Archive_Out, fs)

End Sub

Sub Create_Backup(Backup_Folder As Variant, Archive_In As Variant, fs As Variant)

Dim i, f
Dim a As Integer

For Each i In Archive_In.Items
    i.SaveAs (Backup_Folder & "\" & a & ".msg")
    a = a + 1
Next
For Each f In Archive_In.Folders
    fs.createfolder (Backup_Folder & "\" & f)
    Call Create_Backup(Backup_Folder & "\" & f, f, fs)
Next
End Sub

I haven't really tested it but I think what you want is:

Option Explicit
Sub macro_1()

Dim Folder_A, Folder_B, fs, Target_Folder, Search_Folder

Set fs = CreateObject("scripting.filesystemobject")
Set Folder_A = fs.getfolder("E:\Test Folder A") ' change filepath as appropriate
Set Folder_B = fs.getfolder("E:\Test Folder B") ' change filepath as appropriate

For Each Target_Folder In Folder_B.subFolders
    For Each Search_Folder In Folder_A.subFolders
        If InStr(1, Target_Folder.Name, Search_Folder.Name) Then
            Call Copy_Folders(Target_Folder, Search_Folder, fs)
        End If
    Next
Next Target_Folder

End Sub



Sub Copy_Folders(Dest_Folder As Variant, Source_Folder As Variant, fs As Variant)

Dim i, f
Dim a As Integer

For Each i In Source_Folder.Files
    fs.copyfile i, Dest_Folder & "\" & i.Name
    a = a + 1
Next
For Each f In Source_Folder.subFolders
    fs.createfolder (Dest_Folder & "\" & f)
    Call Copy_Folders(Dest_Folder & "\" & f, f, fs)
Next
End Sub

Thanks very much for that, yudlugar!

It put my PC out of action for about 20 minutes , unfortunately however I received an error RE: the line I have highlighted in red;

Option Explicit
Sub macro_1()

Dim Folder_A, Folder_B, fs, Target_Folder, Search_Folder

Set fs = CreateObject("scripting.filesystemobject")
Set Folder_A = fs.getfolder("E:\Test Folder A") ' change filepath as appropriate
Set Folder_B = fs.getfolder("E:\Test Folder B") ' change filepath as appropriate

For Each Target_Folder In Folder_B.subFolders
    For Each Search_Folder In Folder_A.subFolders
        If InStr(1, Target_Folder.Name, Search_Folder.Name) Then
            Call Copy_Folders(Target_Folder, Search_Folder, fs)
        End If
    Next
Next Target_Folder

End Sub



Sub Copy_Folders(Dest_Folder As Variant, Source_Folder As Variant, fs As Variant)

Dim i, f
Dim a As Integer

For Each i In Source_Folder.Files
    fs.copyfile i, Dest_Folder & "\" & i.Name
    a = a + 1
Next
For Each f In Source_Folder.subFolders
    fs.createfolder (Dest_Folder & "\" & f)

Call Copy_Folders(Dest_Folder & "\" & f, f, fs)
Next
End Sub

Sorry but I am very new with VBA - please could you confirm whether there was any other manual inputs required in your code other than those I have highlighted in yellow?

Many thanks,

Tom

Sorry, I made a bit of an error on that one, it should be

For Each f In Source_Folder.subFolders
    fs.createfolder (Dest_Folder & "\" & f.name)

Call Copy_Folders(Dest_Folder & "\" & f.name, f, fs)
Next

I think. Was it working up to that point (i.e. did it move anything?)

No worries! No it doesn't look like any files were moved when I ran it.

Should I be inputting a name of the folder I want it to create (which would be called "Close Down Forms")?

Thanks,

Tom

Apologies, I did not mention the error I received which was: Run-time error '76': Path not found.

Tom

Ah I forgot about that bit:

Option Explicit
Sub macro_1()

Dim Folder_A, Folder_B, fs, Target_Folder, Search_Folder

Set fs = CreateObject("scripting.filesystemobject")
Set Folder_A = fs.getfolder("E:\Test Folder A") ' change filepath as appropriate
Set Folder_B = fs.getfolder("E:\Test Folder B") ' change filepath as appropriate

For Each Target_Folder In Folder_B.subFolders
    For Each Search_Folder In Folder_A.subFolders
        If InStr(1, Target_Folder.Name, Search_Folder.Name) Then
            fs.createfolder(Target_Folder & "\Close Down Forms")
            Call Copy_Folders(Target_Folder & "\Close Down Forms", Search_Folder, fs)
        End If
    Next
Next Target_Folder

End Sub



Sub Copy_Folders(Dest_Folder As Variant, Source_Folder As Variant, fs As Variant)

Dim i, f
Dim a As Integer

For Each i In Source_Folder.Files
    fs.copyfile i, Dest_Folder & "\" & i.Name
    a = a + 1
Next
For Each f In Source_Folder.subFolders
    fs.createfolder (Dest_Folder & "\" & f.name)

Call Copy_Folders(Dest_Folder & "\" & f.name, f, fs)
Next
End Sub

I'm not sure though, I tested it as best I could with some dummy folders and it seemed to pick up the files and copy them across. If it got as far as the line you mention then it should have copied something by that point.

Also, I think this is pushing the limits of what could be called "excel vba"! Are the files at least .xls?

Thanks very much for re-pasting the code with the updated Folder Name entry, yudlugar.

Yes all of the files contained in the folders are .xlsx - I did think it may be a little unreasonable to request such a code on an Excel/VBA forum, however I currently have a limited knowledge of Excel while zero knoiwledge of Command Prompt (I had previously searched various forums where several methods using RoboCopy, PowerShell, .BAT etc. were offered but unfortunately I couldn't get my head around any of them!).

Thank you for all of your help with this, it's very much appreciated. I will try the updated code you have provided and re-post once I have done. I may also try it on a smaller batch of files to begin with as the time it takes to finish is between 20 & 30 minutes on my horrendously slow laptop.

Will keep you posted...

Tom

Just a quick update - I tried the code using some test files e.g "TEST A" containing folders "1" & "2" and "TEST B" with the same folders. Any Excel files that I place in 1 & 2 in TEST A are pulled through and copied into TEST B 1 & 2 which is great.

Unfortunately when I try to implement it using a copy of the actual data that will be copied, it doesn't work. It runs for around 30 mins before giving a runtime error, highlighting the line below;

Option Explicit
Sub macro_1()

Dim Folder_A, Folder_B, fs, Target_Folder, Search_Folder

Set fs = CreateObject("scripting.filesystemobject")
Set Folder_A = fs.getfolder("E:\Test Folder A") ' change filepath as appropriate
Set Folder_B = fs.getfolder("E:\Test Folder B") ' change filepath as appropriate

For Each Target_Folder In Folder_B.subFolders
    For Each Search_Folder In Folder_A.subFolders
        If InStr(1, Target_Folder.Name, Search_Folder.Name) Then
            fs.createfolder(Target_Folder & "\Close Down Forms")
            Call Copy_Folders(Target_Folder & "\Close Down Forms", Search_Folder, fs)
        End If
    Next
Next Target_Folder

End Sub



Sub Copy_Folders(Dest_Folder As Variant, Source_Folder As Variant, fs As Variant)

Dim i, f
Dim a As Integer

For Each i In Source_Folder.Files
    fs.copyfile i, Dest_Folder & "\" & i.Name
    a = a + 1
Next
For Each f In Source_Folder.subFolders
    fs.createfolder (Dest_Folder & "\" & f.name)

Call Copy_Folders(Dest_Folder & "\" & f.name, f, fs)
Next
End Sub

I can't seem to work out why this is happening, especially as the test run seems to work fine. Is anyone aware of anything that could be blocking it? Interestingly it seems to lock onto two folders, change their name slightly (adding some additional words) and places several empty folders with names of other projects (these have no relation to one another).

Many thanks,

Tom

Does it work if you put the test folders in the same drive/location as the actual data?

Afternoon, yudlugar - apologies for taking so long to reply.

It does work when using a test folders in each of the dummy data locations (providing the filepath of the test folders in the macro you provided). Do you think the problem is likely more to do with the filename following the 4 digit ID number? Apologies I cannot be of more help, although I expect I will learn quite a lot through (hopefully) resolving this....

I'm pretty stumped at this. The only thing I can think of is if you are trying to create a folder with a folder name that already exists. I can't see how that would happen though as it should be putting everything in a new folder called closed down forms.

When you get to having an error, try highlighting what is right of the equals sign on the line with the error (Dest_Folder & "\" & f.name), right click and then add watch. click ok on the dialog box and you should get a watch window that tells you the name of the folder you are trying to create. Have a look at this and see if there is any reason you couldn't make that folder (eg. the folder path is not valid, there is a weird symbol etc). See if you can manually create the folder VBA is trying to.

Hi yudlugar,

I have done what you said and the error was 'Run-time error 76: Path not found'. When added to watch, the following is provided;

Watch : : Error : "Path not found" : Variant/String : Module1.Copy_Folders

It seems to take around 30-40 minutes to run before this happens, and no folders/files are copied or created in the target folder. Is there any way of making the search more specific, such as looking only at the first 4 characters in each folder?