Adding individual folders to created files-CodePudding

I have an excel file which serves as a template file, that needs to generate new files according to a list of names.

How do I save them in individual folders with the same name as the file (person's name).

This is what I have:

Sub SaveMasterAs()
Dim wb As Workbook
Dim rNames As Range, c As Range, r As Range
'Current file's list of names and ids on sheet1.
Set rNames = Worksheets("Sheet1").Range("A2", Worksheets("Sheet1").Range("A2").End(xlDown))
'Path and name to master workbook to open for copy, saveas.
Set wb = Workbooks.Open(ThisWorkbook.Path & "\template_2021.xlsm")
For Each c In rNames
With wb
.SaveAs Filename:=ThisWorkbook.Path & "\templates" & c.Value & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
Set wb = ActiveWorkbook
Next c
wb.Close
End Sub

CodePudding user response：

I think what you want to put in your code is:

MkDir "C:\yourFolderPath"

That would create directory and then you have to save your file into it.

CodePudding user response：

Copy Worksheets to Subfolders

Use variables to make the code more readable and maintainable.

Option Explicit

Sub SaveMasterAs()
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("Sheet1")
    
    'Current file's list of names and ids on sheet1.
    Dim rNames As Range
    Set rNames = sws.Range("A2", sws.Range("A2").End(xlDown))
    ' This is usually the preferred (safer) way:
    'Set rNames = sws.Range("A2", sws.Range("A" & sws.Rows.Count).End(xlUp))
    
    'Path and name to master workbook to open for copy, saveas.
    Dim dwb As Workbook
    Set dwb = Workbooks.Open(swb.Path & "\template_2021.xlsm")
    
    Dim c As Range
    Dim cString As String
    Dim dFilePath As String
    
    For Each c In rNames.Cells
        cString = CStr(c.Value)
        If Len(cString) > 0 Then ' blank cell
            dFilePath = swb.Path & "\templates\" _
                & cString & "\" & cString & ".xlsm"
            'Debug.Print dFilePath ' to check if it is correct
            dwb.SaveAs Filename:=dFilePath, _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        End If
    Next c
    
    dwb.Close SaveChanges:=False ' just in case

End Sub