VBA code edit to add auto save path and filename

Brooksy1 · Jun 8, 2017

Morning all,

I am using the below code to create multiple sheets from a data sheet. Currently when i run the code it asks if i want to save them and i then have to select a folder for them to go into.

I would like to remove the question and get the code to automatically save the workbooks it creates within a predefined folder then within another folder that it will create that is named by the contents of a cell in the data sheet. Additionally it would be great if i could add a predefined password to the workbooks it saves. This would be set within the code so no need to type it in each time.

Is there anyone that can point me in the right direction to edit the code to do the above? I managed to edit it to save in a predefined folder but not to create the new folder. The code below is the original without this edit as my edits may not have been the cleanest.

Many thanks for your help.

Code:

Option Explicit

Sub FillOutindividualschedules()
'From Sheet1 data fill out template on sheet2 and save
'each sheet as its own file.
Dim LastRw As Long, Rw As Long, Cnt As Long
Dim dSht As Worksheet, tSht As Worksheet
Dim MakeBooks As Boolean, SavePath As String

Application.ScreenUpdating = False  'speed up macro execution
Application.DisplayAlerts = False  'no alerts, default answers used

Set dSht = Sheets("Calculations")  'sheet with data on it starting in row2
Set tSht = Sheets("ScheduleTemplate")      'sheet to copy and fill out

'Option to create separate workbooks
    MakeBooks = MsgBox("Create separate workbooks?" & vbLf & vbLf & _
        "YES = template will be copied to separate workbooks." & vbLf & _
        "NO = template will be copied to sheets within this same workbook", _
            vbYesNo + vbQuestion) = vbYes

If MakeBooks Then  'select a folder for the new workbooks
    MsgBox "Please select a destination for the new workbooks"
    Do
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count > 0 Then    'a folder was chosen
                SavePath = .SelectedItems(1) & "\"
                Exit Do
            Else                                'a folder was not chosen
                If MsgBox("Do you wish to abort?", _
                    vbYesNo + vbQuestion) = vbYes Then Exit Sub
            End If
        End With
    Loop
End If

'Determine last row of data then loop through the rows one at a time
    LastRw = dSht.Range("C" & Rows.Count).End(xlUp).Row
  
    For Rw = 12 To LastRw
        tSht.Copy After:=Worksheets(Worksheets.Count)  'copy the template
        With ActiveSheet                                'fill out the form
            'edit these rows to fill out your form, add more as needed
            .Name = dSht.Range("C" & Rw)
            .Range("C9").Value = dSht.Range("A" & Rw).Value
            .Range("C11").Value = dSht.Range("H" & Rw).Value
            .Range("C12").Value = dSht.Range("G" & Rw).Value
            .Range("C13").Value = dSht.Range("I" & Rw).Value
            .Range("C14").Value = dSht.Range("K" & Rw).Value
            .Range("C15").Value = dSht.Range("Q" & Rw).Value
            .Range("C16").Value = dSht.Range("R" & Rw).Value
            .Range("C17").Value = dSht.Range("L" & Rw).Value
            .Range("C18").Value = dSht.Range("S" & Rw).Value
            .Range("C19").Value = dSht.Range("V" & Rw).Value
            .Range("C24").Value = dSht.Range("AC" & Rw).Value
            .Range("D24").Value = dSht.Range("AB" & Rw).Value
            .Range("C25").Value = dSht.Range("AD" & Rw).Value
            .Range("D25").Value = dSht.Range("AB" & Rw).Value
            .Range("C26").Value = dSht.Range("AE" & Rw).Value
            .Range("D26").Value = dSht.Range("AB" & Rw).Value
            .Range("C27").Value = dSht.Range("AF" & Rw).Value
            .Range("C31").Value = dSht.Range("AH" & Rw).Value
            .Range("C32").Value = dSht.Range("AK" & Rw).Value
            .Range("C33").Value = dSht.Range("AO" & Rw).Value
            .Range("C34").Value = dSht.Range("AQ" & Rw).Value
            .Range("C35").Value = dSht.Range("AS" & Rw).Value
            .Range("C43").Value = dSht.Range("M" & Rw).Value
            .Range("D43").Value = dSht.Range("T" & Rw).Value
            .Range("C44").Value = dSht.Range("N" & Rw).Value
            .Range("D44").Value = dSht.Range("T" & Rw).Value
            .Range("C45").Value = dSht.Range("O" & Rw).Value
            .Range("D45").Value = dSht.Range("T" & Rw).Value
            .Range("B51").Value = dSht.Range("Y" & Rw).Value
            .Range("C51").Value = dSht.Range("Z" & Rw).Value
            .Range("D51").Value = dSht.Range("AA" & Rw).Value
        End With
      
        If MakeBooks Then      'if making separate workbooks from filled out form
            ActiveSheet.Move
            ActiveWorkbook.Saveas SavePath & Range("C9").Value, xlNormal
            ActiveWorkbook.Close False
        End If
        Cnt = Cnt + 1
    Next Rw

    dSht.Activate
    If MakeBooks Then
        MsgBox "Workbooks created: " & Cnt
    Else
        MsgBox "Worksheets created: " & Cnt
    End If
  
Application.ScreenUpdating = True
End Sub

VBA code edit to add auto save path and filename

Brooksy1

New Member