View Full Version : Copying spreadsheet into 120 sub-folders

Lee S.
07-08-2019, 07:05 AM
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.

07-08-2019, 06:34 PM
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
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
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


Lee S.
07-09-2019, 07:55 AM
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 S.
07-09-2019, 11:05 AM
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.