vba to create year and month folders to then save the workbook multiple times for each day of the month

[Craig_Moore]

Hi ALL

I have the below code which works great, but i was wondering if there was a way for the code to create a year folder and then a month folder then save the workbook the correct amount of times in to each moth folder?

any help would be welcome

Thanks

Craig

Private Sub CommandButton1_Click()
 Application.ScreenUpdating = False
Dim sFilename As Variant
    Dim sName As String
    Dim sExtension As String
    Dim dDate As Date
    Dim nLeapYear As Integer
    Dim n As Integer 'date counter
    Dim worksheets As String
'  line below re hides the vba download before saving the file
  
  ThisWorkbook.worksheets("VBA DOWNLOAD").Visible = xlSheetVeryHidden
   
    sFilename = Application.GetSaveAsFilename(fileFilter:=".xlsm (*.xlsx; *.xlsm), *.xlsx; *.xlsm")
   
   If sFilename <> "" Then
     sName = Left(sFilename, InStr(sFilename, ".") - 1)
        sExtension = Right(sFilename, Len(sFilename) - Len(sName))
       
        dDate = Range("START_DATE").Value
    
        If MsgBox("Is this a leapyear?", vbYesNo) = vbYes Then
            nLeapYear = 1
        Else
            nLeapYear = 0
        End If
       
       'line below refers to cell in vba download sheet change cell value to quantity of saves total including fisrt date
       
        For n = 1 To Range("DATE_COUNT").Value
        
            sFilename = Format(dDate, "dd-mm-YY")
            Application.StatusBar = " Exporting File Dated: " & dDate
            
            ActiveWorkbook.SaveAs Filename:=sFilename
            dDate = dDate + 1
            Application.ScreenUpdating = True
        Next n
    End If
    Application.StatusBar = "SAVE HAS COMPLETED"
    
    End Sub

 

[HaHoBe]

Hi Craig:Moore,

maybe start with something like

Private Sub CommandButton1_Click()
' https://www.mrexcel.com/board/threads/vba-to-creat-year-and-month-folders-to-then-save-the-workbook-multiple-times-for-each-day-of-the-month.1225478/
Dim lngYear         As Long
Dim lngMonth        As Long
Dim lngDay          As Long
Dim strYearNew      As String
Dim strMonthNew     As String
Dim strCurDir       As String

Const cstrPath      As String = "C:\Result\"    'change to suit

ThisWorkbook.worksheets("VBA DOWNLOAD").Visible = xlSheetVeryHidden

lngYear = Application.InputBox("Choose the year", "Year Planner", Type:=1)
If lngYear = False Then Exit Sub
Application.ScreenUpdating = False
strCurDir = CurDir
If Dir(cstrPath & lngYear, vbDirectory) = "" Then
  strYearNew = cstrPath & lngYear & "\"
  MkDir strYearNew
  ChDrive Left(cstrPath, 1)
  ChDir strYearNew
  For lngMonth = 1 To 12
    strMonthNew = strYearNew & Format(DateSerial(lngYear, lngMonth, 1), "yyyy-mm") & "\"
    MkDir strMonthNew
    ChDir strMonthNew
    For lngDay = 1 To Day(DateSerial(lngYear, lngMonth + 1, 0))
      ThisWorkbook.SaveCopyAs Filename:=strMonthNew & Format(DateSerial(lngYear, lngMonth, lngDay), "yyyy-mm-dd") & ".xlsm"
    Next lngDay
  ChDir strYearNew
  Next lngMonth
End If

ChDrive Left(strCurDir, 1)
ChDir strCurDir
Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[Craig_Moore]

Hi that

Hi Craig:Moore,

maybe start with something like

Private Sub CommandButton1_Click()
' https://www.mrexcel.com/board/threads/vba-to-creat-year-and-month-folders-to-then-save-the-workbook-multiple-times-for-each-day-of-the-month.1225478/
Dim lngYear         As Long
Dim lngMonth        As Long
Dim lngDay          As Long
Dim strYearNew      As String
Dim strMonthNew     As String
Dim strCurDir       As String

Const cstrPath      As String = "C:\Result\"    'change to suit

ThisWorkbook.worksheets("VBA DOWNLOAD").Visible = xlSheetVeryHidden

lngYear = Application.InputBox("Choose the year", "Year Planner", Type:=1)
If lngYear = False Then Exit Sub
Application.ScreenUpdating = False
strCurDir = CurDir
If Dir(cstrPath & lngYear, vbDirectory) = "" Then
  strYearNew = cstrPath & lngYear & "\"
  MkDir strYearNew
  ChDrive Left(cstrPath, 1)
  ChDir strYearNew
  For lngMonth = 1 To 12
    strMonthNew = strYearNew & Format(DateSerial(lngYear, lngMonth, 1), "yyyy-mm") & "\"
    MkDir strMonthNew
    ChDir strMonthNew
    For lngDay = 1 To Day(DateSerial(lngYear, lngMonth + 1, 0))
      ThisWorkbook.SaveCopyAs Filename:=strMonthNew & Format(DateSerial(lngYear, lngMonth, lngDay), "yyyy-mm-dd") & ".xlsm"
    Next lngDay
  ChDir strYearNew
  Next lngMonth
End If

ChDrive Left(strCurDir, 1)
ChDir strCurDir
Application.ScreenUpdating = True

End Sub

Ciao,
Holger

Hi thanks for the reply,

the code gives a run time error 5 when it gets to the

ChDrive Left(cstrPath, 1)

but then when the code runs a second time it then doesn't error but skips down to the end if with out creating the month folders or saving the document for the year

not sure why this is

any further help would be much appreciated

thanks

Craig

 

[HaHoBe]

Hi Craig,

you should have listed the contents of cstrPath as well. The first code posted was originally designed to omitt the path to where to save the files. Please try this version as you will not need to change folders here:

Private Sub CommandButton1_Click()
' https://www.mrexcel.com/board/threads/vba-to-creat-year-and-month-folders-to-then-save-the-workbook-multiple-times-for-each-day-of-the-month.1225478/
Dim lngYear         As Long
Dim lngMonth        As Long
Dim lngDay          As Long
Dim strYearNew      As String
Dim strMonthNew     As String

Const cstrPath      As String = "C:\Result\"    'change to suit

ThisWorkbook.worksheets("VBA DOWNLOAD").Visible = xlSheetVeryHidden

lngYear = Application.InputBox("Choose the year as four-digit like '2023'", "Year Planner", Type:=1)
If lngYear = False Then Exit Sub
Application.ScreenUpdating = False
If Dir(cstrPath & lngYear, vbDirectory) = "" Then
  strYearNew = cstrPath & lngYear & "\"
  MkDir strYearNew
  For lngMonth = 1 To 12
    strMonthNew = strYearNew & Format(DateSerial(lngYear, lngMonth, 1), "yyyy-mm") & "\"
    MkDir strMonthNew
    For lngDay = 1 To Day(DateSerial(lngYear, lngMonth + 1, 0))
      ThisWorkbook.SaveCopyAs Filename:=strMonthNew & Format(DateSerial(lngYear, lngMonth, lngDay), "yyyy-mm-dd") & ".xlsm"
    Next lngDay
  Next lngMonth
End If

Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[Craig_Moore]

Hi Craig,

you should have listed the contents of cstrPath as well. The first code posted was originally designed to omitt the path to where to save the files. Please try this version as you will not need to change folders here:

Private Sub CommandButton1_Click()
' https://www.mrexcel.com/board/threads/vba-to-creat-year-and-month-folders-to-then-save-the-workbook-multiple-times-for-each-day-of-the-month.1225478/
Dim lngYear         As Long
Dim lngMonth        As Long
Dim lngDay          As Long
Dim strYearNew      As String
Dim strMonthNew     As String

Const cstrPath      As String = "C:\Result\"    'change to suit

ThisWorkbook.worksheets("VBA DOWNLOAD").Visible = xlSheetVeryHidden

lngYear = Application.InputBox("Choose the year as four-digit like '2023'", "Year Planner", Type:=1)
If lngYear = False Then Exit Sub
Application.ScreenUpdating = False
If Dir(cstrPath & lngYear, vbDirectory) = "" Then
  strYearNew = cstrPath & lngYear & "\"
  MkDir strYearNew
  For lngMonth = 1 To 12
    strMonthNew = strYearNew & Format(DateSerial(lngYear, lngMonth, 1), "yyyy-mm") & "\"
    MkDir strMonthNew
    For lngDay = 1 To Day(DateSerial(lngYear, lngMonth + 1, 0))
      ThisWorkbook.SaveCopyAs Filename:=strMonthNew & Format(DateSerial(lngYear, lngMonth, lngDay), "yyyy-mm-dd") & ".xlsm"
    Next lngDay
  Next lngMonth
End If

Application.ScreenUpdating = True

End Sub

Ciao,
Holger

Hi
sorry to pester again, i now need to change the code so it produces weekly sheets instead of daily sheets is this an easy fix / change any further help is much appreciated


thanks

Craig

 

[HaHoBe]

Hi Craig,

you would need to specify about the starting day for each workbook (are they to be consecutive for each year or for each month) and if the folders for the months still are needed or how they should look like.

Holger

 

[Craig_Moore]

Hi Holger,

on the first Monday of the year i.e this year the 02/01/23 then consecutive very 7 days up to 52 weeks (workbooks) and any dates that start in Jan would go in to the Jan folder and so on

thanks for the reply

Craig

 

[HaHoBe]

Hi Craig,

what about this:

Private Sub CommandButton1_Click()
' https://www.mrexcel.com/board/threads/vba-to-creat-year-and-month-folders-to-then-save-the-workbook-multiple-times-for-each-day-of-the-month.1225478/
Dim lngYear         As Long
Dim lngMonth        As Long
Dim lngDay          As Long
Dim strYearNew      As String
Dim strMonthNew     As String
Dim dteMonday       As Date

Const cstrPath      As String = "C:\Result\"    'change to suit

ThisWorkbook.worksheets("VBA DOWNLOAD").Visible = xlSheetVeryHidden

lngYear = Application.InputBox("Choose the year as four-digit like '2023'", "Year Planner", Type:=1)
If lngYear = False Then Exit Sub
Application.ScreenUpdating = False
If Dir(cstrPath & lngYear, vbDirectory) = "" Then
  strYearNew = cstrPath & lngYear & "\"
  MkDir strYearNew
  For lngMonth = 1 To 12
    strMonthNew = strYearNew & Format(DateSerial(lngYear, lngMonth, 1), "yyyy-mm") & "\"
    MkDir strMonthNew
  Next lngMonth
  For lngDay = Day(YearStart(lngYear)) To CLng(DateSerial(lngYear, 12, 31) - DateSerial(lngYear - 1, 12, 31)) Step 7
    dteMonday = DateSerial(lngYear, 1, lngDay)
    strMonthNew = Format(DateSerial(lngYear, 1, lngDay), "yyyy-mm") & "\"
    ThisWorkbook.SaveCopyAs Filename:=strYearNew & strMonthNew & "week " & dteMonday & "-" & dteMonday + 6 & ".xlsm"
  Next lngDay

End If

Application.ScreenUpdating = True

End Sub

Public Function YearStart(WhichYear As Long) As Date
'http://www.cpearson.com/excel/datetimevba.htm
Dim WeekDay As Integer
Dim NewYear As Date

NewYear = DateSerial(WhichYear, 1, 1)
WeekDay = (NewYear - 2) Mod 7 'Generate weekday index where Monday = 0

If WeekDay < 4 Then
  YearStart = NewYear - WeekDay
Else
  YearStart = NewYear - WeekDay + 7
End If

End Function

The folders for the months are inserted first, then a loop covering the span of the year from the date of the first monday to the last day of the year is started (using each Monday as next counter), the month of the starting Monday is used to get the folder name and save workbook there. Please adjust the path for the folders and the name of the workbooks to suit.

Holger

 

[Craig_Moore]

Hi Holger,

the file creation works great, but i get a run time error 1004 and it doesn't save any files it errors after the public function has cycle through once and then errors when it gets to:
ThisWorkbook.SaveCopyAs Filename:=strYearNew & strMonthNew & "week " & dteMonday & "-" & dteMonday + 6 & ".xlsm"

thanks

Craig

Private Sub CREATE_SHEETS_FOR_YEAR_Click()

' https://www.mrexcel.com/board/threads/vba-to-creat-year-and-month-folders-to-then-save-the-workbook-multiple-times-for-each-day-of-the-month.1225478/
Dim lngYear         As Long
Dim lngMonth        As Long
Dim lngDay          As Long
Dim strYearNew      As String
Dim strMonthNew     As String
Dim dteMonday       As Date

Const cstrPath      As String = "\\ACRLFILE01\company\Beta Shift Managers\Shift Handover Report\"    'change to suit


lngYear = Application.InputBox("Choose the year as four-digit like '2023'", "Year Planner", Type:=1)
If lngYear = False Then Exit Sub
Application.ScreenUpdating = False
If Dir(cstrPath & lngYear, vbDirectory) = "" Then
  strYearNew = cstrPath & lngYear & "\"
  MkDir strYearNew
  For lngMonth = 1 To 12
    strMonthNew = strYearNew & Format(DateSerial(lngYear, lngMonth, 1), "yyyy-mm") & "\"
    MkDir strMonthNew
  Next lngMonth
  For lngDay = Day(YearStart(lngYear)) To CLng(DateSerial(lngYear, 12, 31) - DateSerial(lngYear - 1, 12, 31)) Step 7
    dteMonday = DateSerial(lngYear, 1, lngDay)
    strMonthNew = Format(DateSerial(lngYear, 1, lngDay), "yyyy-mm") & "\"
    ThisWorkbook.SaveCopyAs Filename:=strYearNew & strMonthNew & "week " & dteMonday & "-" & dteMonday + 6 & ".xlsm"
  Next lngDay

End If

Application.ScreenUpdating = True

End Function

Public Function YearStart(WhichYear As Long) As Date
'http://www.cpearson.com/excel/datetimevba.htm
Dim WeekDay As Integer
Dim NewYear As Date

NewYear = DateSerial(WhichYear, 1, 1)
WeekDay = (NewYear - 2) Mod 7 'Generate weekday index where Monday = 0

If WeekDay < 4 Then
  YearStart = NewYear - WeekDay
Else
  YearStart = NewYear - WeekDay + 7
End If

End Function

 

[HaHoBe]

Hi Craig,

the function YearStart is only called once in the procedure. I started the procedure via an ActiveX-Button in a sheet, Procedure and Function behind that sheet, code created Folder and SubFolders for 2023 as wanted, pressing again and reentering 2023 skips the procedure. Entering 2024 was working fine again.

The procedure you posted starts as Private Sub CREATE_SHEETS_FOR_YEAR_Click() and should end with End Sub, not with End Function.

Holger