Macro to create duplicate "Workbook" that contains 6 worksheets. One for every day of year

[GARTHMAN]

Is there a way to do the following... I have a workbook template that contains 6 spreadsheets. The layout of 5 of the spreadsheets are identical and contain data that is manually entered. The 6th spreadsheet layout is always the same but automatically pulls data from the manually entered data. The workbook name will equal "MMM-DD-YYYY". Can I use VBA to generate a workbook for every day of the next fiscal year? Thanks for any suggestions.

 

[Logit]

The following will create a copy of the workbook this macro is pasted into, then create a separate copy of the workbook for each day of the year.

The workbooks will be separated into their own monthly folders labelled Jan, Feb, Mar, etc.

Option Explicit

Sub Create_Multiple_Workbooks()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    '
    Dim i As Long
    Dim wb As Workbook
    Dim fec1 As Date, fec2 As Date
    Dim l1 As Workbook, h1 As Worksheet
    Dim ruta As String, mes As String, ruta2 As String, arch As String
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Template")      'name of template sheet
    '
    ruta = l1.Path & "\"
    fec1 = DateSerial(Year(Date), 1, 1)
    fec2 = DateSerial(Year(Date), 12, 31)
    For i = fec1 To fec2
        Application.StatusBar = "Creating file : " & i
        mes = Format(i, "mmm")
        If Dir(ruta & mes & "\") = "" Then
            MkDir (ruta & mes)
        End If
        ruta2 = ruta & mes & "\"
        arch = "cash-out " & Format(i, "mm-dd-yyyy")
        h1.Copy
        Set wb = ActiveWorkbook
        wb.SaveAs Filename:=ruta2 & arch & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook
        wb.Close False
    Next
    Application.StatusBar = False
    MsgBox "End"
End Sub

Presently the workbooks will be named Cash-Out and the date : "mm-dd-yyyy"
That can be changed as needed in the macro.

 

[GARTHMAN]

This is almost what I am seeking to accomplish. It creates a workbook for each day as desired. However, is there a way to do this and include the additional 5 sheets from the original workbook? They contain no data or formulas. They are only set up for data entry. Thanks for where you've gotten me thus far. If need be, I can copy and move remaining sheets to each of the 365 workbooks. Trying to avoid that, but what you have provided will save a lot of time!

 

[Logit]

Paste the macro into the workbook with the 6 sheets. Then run the macro.
It will make copies of the workbook with the 6 sheets for each day of the year.

 

[GARTHMAN]

I have pasted the code in the workbook and ran the macro. However, the result is files with only the 1st spreadsheet. I am navigating to View>Macro>CREATE_MULTIPLE_WORKBOOKS, then pasting the code, compiling the project, then running the macro. Am I pasting the code in the wrong location? I have also tried pasting it in the view code of the tab for the primary worksheet. Same results. Can I call out the name of each worksheet to be copied in the new workbooks and if so can you tell me how that code might look? thanks again

 

[Logit]

Use this version instead :

Option Explicit

Sub Create_Multiple_Workbooks()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    '
    Dim i As Long
    Dim wb As Workbook
    Dim fec1 As Date, fec2 As Date
    Dim l1 As Workbook, h1 As Worksheet
    Dim ruta As String, mes As String, ruta2 As String, arch As String
    Set l1 = ThisWorkbook
  
    ruta = l1.Path & "\"
    fec1 = DateSerial(Year(Date), 1, 1)
    fec2 = DateSerial(Year(Date), 12, 31)
    For i = fec1 To fec2
        Application.StatusBar = "Creating file : " & i
        mes = Format(i, "mmm")
        If Dir(ruta & mes & "\") = "" Then
            MkDir (ruta & mes)
        End If
        ruta2 = ruta & mes & "\"
        arch = "cash-out " & Format(i, "mm-dd-yyyy")
        
        ActiveWorkbook.Sheets.Copy
        
        Set wb = ActiveWorkbook
        wb.SaveAs Filename:=ruta2 & arch & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook
        wb.Close False
    Next
    Application.StatusBar = False
    MsgBox "End"
End Sub

 

[GARTHMAN]

This is Most Excellent! You, my friend, are a friggin' genius! Thank you, Merci Beaucoup, Gracias, etc. What a time saver! Now that I see what you did, I can experiment and learn from it.

 

[Logit]

Glad to help. Cheers !