Copy paste content of two folders for the part of the path that matches

[Bering]

I have a source path:

"Z:\SourceFolderTree\"


with this structure:

"Z:\SourceFolderTree\Folder i\subfolder j\202X"

• Folder i means that there can be a variable no. of folders (currently 17)
• subfolder j means that there can be a variable no. of subfolders (currently one folder has 75 subfolder)

Inside each of these subfolders there are sub-subfolders for each year starting from 2021, the actual data I need to copy is stored at this level.

I'd like to copy the entire folder structure into a different path but excluding previous years, hence only keeping the data relating to 2023.

I managed to create an exact replica of the source folder-tree in my destination path excluding the years prior to 2023.
The idea is to copy all the content from the source to the destination folders if the path matches, i.e;:

copy all the content of:
Z:\SourceFolderTree\Folder 1\subfolder 1\2023
Z:\SourceFolderTree\Folder 1\subfolder 2\2023
etc

to

Y:\My Documents\DestinationFolderTree\Folder 1\subfolder 1\2023
Y:\My Documents\DestinationFolderTree\Folder 1\subfolder 2\2023

I hope this is clear..

Any idea please? Thanks

 

[NdNoviceHlp]

Hi Bering. Seems like this should work. Please keep a copy of your folder(s) before trialing the code. HTH. Dave

Sub CopyFolders()
Dim OfsObj As Object, Fldr As Object, objFolder As Object
Dim SourceFOlder  As String, DestFolder As String


SourceFOlder = "Z:\SourceFolderTree"
DestFolder = "Y:\My Documents\DestinationFolderTree\"

Set OfsObj = CreateObject("Scripting.FilesystemObject")
Set objFolder = OfsObj.GetFolder(SourceFOlder)
For Each Fldr In objFolder.subfolders
OfsObj.CopyFolder Fldr, DestFolder & Fldr.Name, True
Next Fldr

Set objFolder = Nothing
Set OfsObj = Nothing
End Sub

 

[Bering]

Hi Bering. Seems like this should work. Please keep a copy of your folder(s) before trialing the code. HTH. Dave

Sub CopyFolders()
Dim OfsObj As Object, Fldr As Object, objFolder As Object
Dim SourceFOlder  As String, DestFolder As String


SourceFOlder = "Z:\SourceFolderTree"
DestFolder = "Y:\My Documents\DestinationFolderTree\"

Set OfsObj = CreateObject("Scripting.FilesystemObject")
Set objFolder = OfsObj.GetFolder(SourceFOlder)
For Each Fldr In objFolder.subfolders
OfsObj.CopyFolder Fldr, DestFolder & Fldr.Name, True
Next Fldr

Set objFolder = Nothing
Set OfsObj = Nothing
End Sub

Hi Bering. Seems like this should work. Please keep a copy of your folder(s) before trialing the code. HTH. Dave

Sub CopyFolders()
Dim OfsObj As Object, Fldr As Object, objFolder As Object
Dim SourceFOlder  As String, DestFolder As String


SourceFOlder = "Z:\SourceFolderTree"
DestFolder = "Y:\My Documents\DestinationFolderTree\"

Set OfsObj = CreateObject("Scripting.FilesystemObject")
Set objFolder = OfsObj.GetFolder(SourceFOlder)
For Each Fldr In objFolder.subfolders
OfsObj.CopyFolder Fldr, DestFolder & Fldr.Name, True
Next Fldr

Set objFolder = Nothing
Set OfsObj = Nothing
End Sub

Thanks so much Dave, I tried but it copies all the subfolders including the years prior to 2023 that I want to exclude.
Almost there, I’ll let you know if I manage to fix it. Thanks

 

[NdNoviceHlp]

Hi again Bering. I think that last attempt was a bit simplistic. There's a recursive search that needs to be done plus additional folders need to be created. Again, please save copies of your folder(s) before trialing this code. Dave

Option Explicit
Dim OfsObj As Object

Public Sub Test()
Dim SourceFOlder  As String
SourceFOlder = "Z:\SourceFolderTree"

Set OfsObj = CreateObject("Scripting.FileSystemObject")
CopyFolder OfsObj.GetFolder(SourceFOlder)
Set OfsObj = Nothing
End Sub

Public Sub CopyFolder(Flder)
Dim SubFold As Object, DestFolder As String, SplitTemp As Variant
DestFolder = "Y:\My Documents\DestinationFolderTree\"
   
For Each SubFold In Flder.SubFolders
    CopyFolder SubFold
Next SubFold

For Each SubFold In Flder.SubFolders
If InStr(SubFold, "2023") Then
SplitTemp = Split(SubFold.Path, "\")
If OfsObj.folderexists(DestFolder & SplitTemp(2) & "\" & SplitTemp(3)) = False Then
OfsObj.createfolder DestFolder & SplitTemp(2)
OfsObj.createfolder DestFolder & SplitTemp(2) & "\" & SplitTemp(3)
End If
OfsObj.CopyFolder SubFold, DestFolder & SplitTemp(2) & "\" & SplitTemp(3) & "\" & SubFold.Name, True
End If
Next SubFold
End Sub

To operate paste the code at the top of any code module and run the Test sub. Dave

 

[Bering]

Hi again Bering. I think that last attempt was a bit simplistic. There's a recursive search that needs to be done plus additional folders need to be created. Again, please save copies of your folder(s) before trialing this code. Dave

Option Explicit
Dim OfsObj As Object

Public Sub Test()
Dim SourceFOlder  As String
SourceFOlder = "Z:\SourceFolderTree"

Set OfsObj = CreateObject("Scripting.FileSystemObject")
CopyFolder OfsObj.GetFolder(SourceFOlder)
Set OfsObj = Nothing
End Sub

Public Sub CopyFolder(Flder)
Dim SubFold As Object, DestFolder As String, SplitTemp As Variant
DestFolder = "Y:\My Documents\DestinationFolderTree\"
  
For Each SubFold In Flder.SubFolders
    CopyFolder SubFold
Next SubFold

For Each SubFold In Flder.SubFolders
If InStr(SubFold, "2023") Then
SplitTemp = Split(SubFold.Path, "\")
If OfsObj.folderexists(DestFolder & SplitTemp(2) & "\" & SplitTemp(3)) = False Then
OfsObj.createfolder DestFolder & SplitTemp(2)
OfsObj.createfolder DestFolder & SplitTemp(2) & "\" & SplitTemp(3)
End If
OfsObj.CopyFolder SubFold, DestFolder & SplitTemp(2) & "\" & SplitTemp(3) & "\" & SubFold.Name, True
End If
Next SubFold
End Sub

To operate paste the code at the top of any code module and run the Test sub. Dave

Works like a charm!! Thank you so much!

 

[Fluff]

In future please mark the post that contains the solution, rather than your post saying it works. I have changed it for you this time.

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave

 

[Bering]

In future please mark the post that contains the solution, rather than your post saying it works. I have changed it for you this time.

Thanks