Copying spreadsheet into 120 sub-folders

[Lee S.]

I run a query every month and receive an Excel 2010 spreadsheet.
The spreadsheet has a different name every month based on the date the report is run.
The spreadsheet has a standard naming convention: Date Name of Report.xlsm
Example: 07-05-2019 Payment Report.xlsm
This spreadsheet report needs to be copied into 120 sub-folders inside contained in a folder.
This spreadsheet report has a column labeled Folder_Name which is contains the name of the appropriate sub-folder, if needed.
Each sub-folder name has a standard naming convention: Sponsor ID# Name of Sponsor
Example: 3214 City of Bladeville
I copy the entire report file into the main folder, not in any sub-folder.
Need to create a macro to copy the spreadsheet report file into each sub-folder.
Thanks for any and all help.
Lee

[Artik]

There is some inaccuracy in the description of the task. It is not known whether the file should be copied to all subfolders that exist in the main folder or to all subfolders listed in the Folder_Name column.
I accepted the second version.


It was assumed that the report table is in the first worksheet of workbook and that it starts with cell A1. If any of the subfolders does not exist, it will be created automatically. The main folder is the folder in which selected report file is located.
The file with the following macros can be stored anywhere.

Option Explicit


Sub Copy2SubFolders()
    Dim varRaportName As Variant
    Dim strMainFolder As String
    Dim strSubFolder As String
    Dim strFileName As String
    Dim lngFolder_NameColumn As Long
    Dim varSubFolders As Variant
    Dim Wkb         As Workbook
    Dim Wks         As Worksheet
    Dim Rng         As Range
    Dim FSO         As Object
    Dim i As Long


    varRaportName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*", , "Select the report file", , False)


    If TypeName(varRaportName) = "Boolean" Then Exit Sub


    Set FSO = CreateObject("Scripting.FileSystemObject")


    strMainFolder = GetFolderName(CStr(varRaportName), FSO)


    Set Wkb = Workbooks.Open(varRaportName)
    
    strFileName = Wkb.Name


    Set Wks = Wkb.Worksheets(1)


    Set Rng = Wks.Rows(1).Find(What:="Folder_Name", SearchOrder:=xlByColumns)


    If Rng Is Nothing Then
        MsgBox "There is no column named ""Folder_Name""", vbExclamation, "Oops, something went wrong"
        Set FSO = Nothing
        Exit Sub
    End If


    lngFolder_NameColumn = Rng.Column


    Set Rng = Wks.Range("A1").CurrentRegion.Columns(lngFolder_NameColumn)


    With Rng
        Set Rng = .Offset(1).Resize(.Rows.Count - 1)
    End With


    varSubFolders = Rng.Value


    Wkb.Close False




    For i = 1 To UBound(varSubFolders)
        strSubFolder = strMainFolder & varSubFolders(i, 1)
        If CheckOrCreateMultiFolders(strSubFolder) Then
            strSubFolder = strSubFolder & Application.PathSeparator & strFileName
            FSO.CopyFile Source:=varRaportName, Destination:=strSubFolder
        Else
            MsgBox "This subfolder can not be created:" & vbLf & _
                   strSubFolder & "!", vbExclamation, "Oops, something went wrong"
        End If


    Next i
    
    
    Set FSO = Nothing
    
    MsgBox "Done", vbInformation, "Copying report file"


End Sub




Function CheckOrCreateMultiFolders(strPath As String) As Boolean
    'checks whether the entire path to the (sub)folder exists
    'if it does not exist, it tries to create it.
    'The function returns:
    ' True - when the entire path exists or was successfully created
    ' False - when creation failed (eg due to lack of rights)


    Dim retVal      As Long


    If CreateObject("Scripting.FileSystemObject").FolderExists(strPath) Then
        CheckOrCreateMultiFolders = True
    Else
        retVal = CreateObject("Wscript.Shell").Run("cmd /c " & "md """ & strPath & """", 0, True)
        CheckOrCreateMultiFolders = (retVal = 0)
    End If


End Function




Function GetFolderName(strFullPath As String, Optional FSO As Object) As String
    Dim objFolder   As Object
    Dim IsNotFSO    As Boolean
    Dim objFSO      As Object


    Set objFSO = FSO


    If objFSO Is Nothing Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        IsNotFSO = True
    End If


    If objFSO.FileExists(strFullPath) Then
        GetFolderName = objFSO.GetParentFolderName(strFullPath)
        If Right(GetFolderName, 1) <> Application.PathSeparator Then
            GetFolderName = GetFolderName & Application.PathSeparator
        End If
    End If


    If IsNotFSO Then
        Set objFSO = Nothing
    End If


End Function

Artik

[Lee S.]

Artik, thanks for your gracious assistance, it is greatly appreciated.
I will try the code out hopefully this evening or first thing tomorrow morning and report back the results.


As to your observations:
1. The spreadsheet report workbook has only one worksheet.
The worksheet is a named worksheet, example: WXYZ Sponsor Payments
2. The subfolders in the main folder match the listed, named Folder_Name subfolders on the spreadsheet report.


The report usually has multiple payments for each sponsor so the spreadsheet will have the same Folder_Name listed as many times as the sponsor was paid during the period of the report.


I hope my above explanation is clear.
Again, many thanks for taking your time and sharing.
Lee

[Lee S.]

Artik,
It worked perfectly.
Created folders and all 120 copies of spreadsheet report were copied almost if not instantly.
Really appreciate your code and assistance.
Have a great day.
Lee