505.369.1650 [email protected]
This VBA function copies a set of subfolders from a master folder, and then adds those subfolders to all of the folders in a different location.

For example, let’s say that you already have a folder for each employee under the Employees folder on the network.  But then you decide that you would like to have NDA and Payroll subfolders beneath each employee folder.  Calling this function would add those subfolders beneath each employee folder automatically.

Step 1
Have employee folders in place.  Perhaps your work process in Microsoft Access creates an employee folder automatically each time you add an employee record:
D:\Code Test\Employees\John Doe
D:\Code Test\Employees\Mary Smith

Step 2
Create the EmployeeMaster folder and subfolders, something like this:
D:\Code Test\EmployeeMaster\NDA
D:\Code Test\EmployeeMaster\Payroll

Step 3
Call the function in the Immediate window:

?CopySetOfFolders("D:\Code Test\EmployeeMaster","D:\Code Test\Employees")

These new folders will be added:
D:\Code Test\Employees\John Doe\NDA
D:\Code Test\Employees\John Doe\Payroll
D:\Code Test\Employees\Mary Smith\NDA
D:\Code Test\Employees\Mary Smith\Payroll

This function uses the FileSystemObject, so you will need to set a reference to Microsoft Scripting Runtime in the VBA editor (Tools, References).

Public Function CopySetOfFolders(MasterFolder As String, _
    RootFolder As String) As Boolean
' This procedure copies all of the folders from MasterFolder to
' all of the folders in the RootFolder (some can be excluded
' in the SELECT CASE).
' CopySetOfFolders() Version 1.0.0
' Copyright © 2023 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' Use (at your own risk) and modify freely as long as proper credit is given.
On Error GoTo Err_Handler

    Dim fso As New FileSystemObject
    Dim fol As Folder
    Dim astrFolders() As String
    Dim lngElem As Long
    Dim strFromFolder As String
    Dim strToFolder As String
    ' Initialize the array of folders.
    ReDim astrFolders(100)
    ' Fill the array with all of the folder names from the MasterFolder.
    lngElem = 0
    For Each fol In fso.GetFolder(MasterFolder).SubFolders
        astrFolders(lngElem) = fol.Name
        lngElem = lngElem + 1

    ' Redimension the array to just the list of folders that was created.
    ReDim Preserve astrFolders(lngElem - 1)

    ' Loop through the folders in the RootFolder.
    For Each fol In fso.GetFolder(RootFolder).SubFolders
        Select Case fol.Name
        Case "FolderB", "FolderC"
            ' Ignore these folders.
        Case Else
            Debug.Print fol.Path
            ' Loop through the folders in the array.
            For lngElem = 0 To UBound(astrFolders)
                ' Using the folder name, build the original folder path
                ' and then the path it will get copied to.
                strFromFolder = MasterFolder & "\" & astrFolders(lngElem)
                strToFolder = fol.Path & "\" & astrFolders(lngElem)
                ' Copy the folder.
                fso.CopyFolder strFromFolder, strToFolder
            Next lngElem
        End Select
    Next fol

    ' Message the user.
    MsgBox "Done"

    CopySetOfFolders = True

    On Error Resume Next
    Set fol = Nothing
    Set fso = Nothing
    Exit Function

    MsgBox Err.Number & " " & Err.Description, vbCritical, _
    CopySetOfFolders = False
    Resume Exit_Proc

End Function