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

 

[Craig_Moore]

Hi Holger,

I'm still getting the 1004 error on the line : ThisWorkbook.SaveCopyAs Filename:=strYearNew & strMonthNew & "week " & dteMonday & "-" & dteMonday + 6 & ".xlsm"

i have chnage the eng function to end sub for the private sub CREATE_SHEETS_FOR_YEAR_Click()

thnaks again for the help

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 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

 

[HaHoBe]

Hi Craig,

I just realized that I used

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

which (at least for me) is the default way to do so) in Windows while you use

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

Does the code create the folders? If not I would assume that the given Path would need to get mounted to a Drive-Character in order to work (if you have write and save rights on that drive which I assume).

Holger

 

[Craig_Moore]

Hi Craig,

I just realized that I used

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

which (at least for me) is the default way to do so) in Windows while you use

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

Does the code create the folders? If not I would assume that the given Path would need to get mounted to a Drive-Character in order to work (if you have write and save rights on that drive which I assume).

Holger

Hi Holger

the files create perfectly i can change the address to the mapped dive the only reason i go the the server address is sometimes the computers in the company aren't always mapped to the same letter due to poor practices by the it company we use

i have changed to the mapped address but get the same 1004 error application-defined or object-defined error

thanks again for your help

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 = "Z:\Beta Shift Managers\Shift Handover Report\"

'"\\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 Sub

 

[HaHoBe]

Hi Craig,

sorry but by now I can't find the reason for this (might be too obvious but I can't spot it now). If I have any idea be assured I will come back here.

Holger

 

[Craig_Moore]

Hi Craig,

sorry but by now I can't find the reason for this (might be too obvious but I can't spot it now). If I have any idea be assured I will come back here.

Holger

thankyou for all your help it is much appreciated

Craig