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

C

Craig_Moore

Board Regular
Joined
Dec 12, 2018
Messages
64
Office Version
  1. 2019
Platform
  1. Windows
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


VBA Code: 
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
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
Hi Craig:Moore,

maybe start with something like

VBA Code: 
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
 
Upvote 0
Hi that
HaHoBe said:
Hi Craig:Moore,

maybe start with something like

VBA Code: 
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
Click to expand...

Hi thanks for the reply,

the code gives a run time error 5 when it gets to the
ChDrive Left(cstrPath, 1)
Click to expand...
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
 
Upvote 0
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:

VBA Code: 
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
 
Upvote 0
HaHoBe said:
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:

VBA Code: 
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
Click to expand...

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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Hi Craig,

what about this:

VBA Code: 
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
 
Upvote 0
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

VBA Code: 
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
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Export excel file as PDF into a targeted pc folder based on cell value
Replies
2
Views
197
Ramadan2512
R
L
  • Question Question
VBA to save newly created workbook failing - creates a "file" document
Replies
2
Views
212
Sunjinsak
S
T
  • Solved
Kill Command should work according to everything I have read, but it doesn't
Replies
6
Views
431
Artik
Artik
M
  • Solved
Split a workbook into multiple workbooks and save into new folder
Replies
3
Views
506
mikeyeye
M
O
  • Question Question
Creating workbooks for a team of staff
Replies
1
Views
200
HighAndWilder
H

Forum statistics

Threads
1,223,903
Messages
6,175,287
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top