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



## Craig_Moore (Dec 27, 2022)

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 (Dec 27, 2022)

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 (Dec 29, 2022)

Hi that


HaHoBe said:


> Hi Craig:Moore,
> 
> maybe start with something like
> 
> ...



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 (Dec 29, 2022)

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


----------

