Create complex folder and subfolders

[Rumburak]

Hello,

What code can I use to create a folder - say 2018 (ask me what year I want) in that folder, automatically create subfolders with months of the year, and in each subfolder with the months of the year, create one file with the sheet names of the days. The name of the days can be 1, 2, 3, ... 30 or 31 or Apr 01, Apr 02 .... depending on the days of that month.


Thanks in advance to anyone who wants to help me.

 

[John_w]

A couple of questions to clarify your requirements:

What should the month subfolders be named as? The full month name, the abbreviated month name (3 letters) or the month number, or something else?

For example, with 2018 and abbreviated month names the created folders would be C:\baseFolder\2018\Jan, C:\baseFolder\2018\Feb, etc.

What should the file in each month subfolder be named as? The same file name for every folder, or different file names, depending on the month? What file extension - .xlsx, .xls, or something else?

 

[Logit]

.
Here is one way. I am certain there are plenty other solutions as well :

Option Explicit


Sub CreateDirs()
    Dim R As Range
    Dim RootFolder As String
    
    Dim sFolderPath As String
    sFolderPath = "C:\Users\My\Desktop\" & Range("A1").Value        '<<< Edit path as required
    
    If Right(sFolderPath, 1) <> "\" Then
        sFolderPath = sFolderPath & "\"
    End If
    
    If Dir(sFolderPath, vbDirectory) <> vbNullString Then
        MsgBox "Sorry ... that folder already exists. " & vbCrLf & _
        "Please choose another folder.", vbCritical, "File Folder Error !"
        Exit Sub
    Else
        MkDir "C:\Users\My\Desktop\" & Range("A1").Value            '<<< Edit path as required
    End If
    
    RootFolder = "C:\Users\My\Desktop\" & Range("A1").Value         '<<< Edit path as required
    For Each R In Range("A2:A13")
        If Len(R.Text) > 0 Then
            On Error Resume Next
            MkDir RootFolder & "\" & R.Text
            On Error GoTo 0
        End If
    Next R
    
    CreateSheetsFromAList
    
End Sub


Sub CreateSheetsFromAList()


Dim i As Integer
Dim MyCell As Range, MyRange As Range


i = 1
    For i = 1 To 31                                                 'Each MyCell In MyRange
        Sheets.Add After:=Sheets(Sheets.Count)                      'creates a new worksheet
        Sheets(Sheets.Count).Name = i                               'renames the new worksheet
        
    Next
    Application.DisplayAlerts = False
    Sheets("Sheet1").Delete
    Sheets("Sheet2").Delete
    Sheets("Sheet3").Delete
    Application.DisplayAlerts = True
    Sheets("1").Select
    
    SaveBookAs
    
End Sub


Sub SaveBookAs()


Dim Path As String
Dim filename1 As String
Dim myvalue As String


myvalue = InputBox("Enter 4 Digit Year (Folder Name)", "Which Year ?", "")


Path = "C:\Users\My\Desktop\" & myvalue & "\"                       '<<< Edit path as required
filename1 = "Days Of Month"


Application.DisplayAlerts = False


    ActiveWorkbook.SaveAs Filename:=Path & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "1\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "2\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "3\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "4\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "5\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "6\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "7\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "8\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "9\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "10\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "11\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:=Path & "12\" & filename1, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   
    Dim aFile As String
    aFile = "C:\Users\My\Desktop\" & myvalue & "\Days Of Month.xlsx"    '<<< Edit path as required
    If Len(Dir$(aFile)) > 0 Then
         Kill aFile
    End If
Application.DisplayAlerts = True


MsgBox "All Actions Completed ! ", vbInformation, "Folder Creation ..."
Application.Quit
ActiveWorkbook.Close False
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/ehCUBhzfDvNFzh6NfCr2JiHGrnxoxOYG0un8ejdrcZi

 

[Rumburak]

Thank you both for replying.

@John_w,

In the "2018" folder there will be subfolders with the names of the months of the year, the full name of the month (January, February ... December).
In each subfolder - say, January - there will be a file named January 2018,
in the subfolder - say May - will be a file named May 2018 ....
Each file will have as many sheets as each month has that month.
January with 31 sheets, February with 28 or 29 days depending on year and so on ...
The names of the sheets will be for the sheet January: 01-Jan, 02-Jan ... 31-Jan, for the February sheet: 01-Feb, 02-Feb ....... 28-Feb or 29-Feb.

Thank you very much.

@Logit,

Your code did not allow me to change numbers 1, 2, ... 12 with the names of the months. Error...
Each file has 31 sheets. If possible, they should have as many days as the month of that year.

If I may wish, at the click of a button, ask me what year they want and automatically create that folder with the described subfolders.

Thank you very much.

 

[Logit]

.
You are welcome, so glad I could help.

 

[Rumburak]

.
You are welcome, so glad I could help.

Could you change your code to do :

In the "2018" folder there will be subfolders with the names of the months of the year, the full name of the month (January, February ... December).
In each subfolder - say, January - there will be a file named January 2018,
in the subfolder - say May - will be a file named May 2018 ....
Each file will have as many sheets as each month has that month.
January with 31 sheets, February with 28 or 29 days depending on year and so on ...
The names of the sheets will be for the sheet January: 01-Jan, 02-Jan ... 31-Jan, for the February sheet: 01-Feb, 02-Feb ....... 28-Feb or 29-Feb.

When press a button, VBA code, ask me what year they want and automatically create that folder with the described subfolders.

Thank you.

 

[John_w]

In the "2018" folder there will be subfolders with the names of the months of the year, the full name of the month (January, February ... December).
In each subfolder - say, January - there will be a file named January 2018,
in the subfolder - say May - will be a file named May 2018 ....
Each file will have as many sheets as each month has that month.
January with 31 sheets, February with 28 or 29 days depending on year and so on ...
The names of the sheets will be for the sheet January: 01-Jan, 02-Jan ... 31-Jan, for the February sheet: 01-Feb, 02-Feb ....... 28-Feb or 29-Feb.

Try this macro. Change the baseFolder path - the folder in which the 2018 subfolder will be created.

Public Sub Create_Year_Months_Folders_and_Files()

    Dim baseFolder As String
    Dim inputYear As String
    Dim m As Long, d As Long, numDays As Long
    Dim monthFolder As String, monthlyWorkbook As Workbook
    Dim sheetsCount As Integer
    Dim wbFileName As String
    
    baseFolder = "C:\folder\path\"
    
    If Right(baseFolder, 1) <> "\" Then baseFolder = baseFolder & "\"
    
    Do
        inputYear = InputBox("Enter year (4 digits)")
        If inputYear = "" Then Exit Sub
    Loop Until Len(inputYear) = 4 And IsNumeric(inputYear)
    
    If Dir(baseFolder & inputYear, vbDirectory) = vbNullString Then
        MkDir baseFolder & inputYear
    End If
    
    With Application
        .ScreenUpdating = False
        sheetsCount = .SheetsInNewWorkbook
    End With
    
    baseFolder = baseFolder & inputYear & "\"
    For m = 1 To 12
        monthFolder = baseFolder & MonthName(m, False)
        If Dir(monthFolder, vbDirectory) = vbNullString Then
            MkDir monthFolder
        End If
        numDays = MonthDays(CLng(inputYear), m)
        Application.SheetsInNewWorkbook = numDays
        Set monthlyWorkbook = Workbooks.Add
        For d = 1 To numDays
            'Sheet name is "[Day number]-[Abbreviated Month name]", e.g. 01-Jan, 02-Jan, etc.
            monthlyWorkbook.Worksheets(d).Name = Format(DateSerial(inputYear, m, d), "dd-mmm")
        Next
        'Name of workbook in each month folder is "[Full Month name] [Year]", e.g. January 2018.xlsx, February 2018.xlsx
        wbFileName = monthFolder & "\" & Format(DateSerial(inputYear, m, 1), "Mmmm yyyy")
        monthlyWorkbook.SaveAs wbFileName, FileFormat:=xlOpenXMLWorkbook
        monthlyWorkbook.Close False
        DoEvents
    Next
        
    With Application
        .ScreenUpdating = True
        .SheetsInNewWorkbook = sheetsCount
    End With
        
    MsgBox "Done"
    
End Sub


Private Function MonthDays(yearNumber As Long, monthNumber As Long) As Long
    MonthDays = Day(DateSerial(yearNumber, monthNumber + 1, 1) - 1)
End Function<day number=""><abbreviated month="" name=""><month name=""><year>

</year></month></abbreviated></day>

 

[Rumburak]

@John_w,

Excellent. Excellent.
The code does exactly what we wanted. Superb.
You are the best of the best.
Excellent.
Million thanks.