UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Create Month And Date Wise Sub Folder Based On Year (including Leap Year), Office 2010    
 
   
vajeeth
post May 4 2019, 05:40 AM
Post#1



Posts: 49
Joined: 29-July 16
From: Chennai, India


Hi Team,

Hope all doing well, I am new to excel VBA and need your help on my request to create all the month as folder name inside the month folder would like to create date wise wise folder based on choosing year which also included leap year. I have list of year in excel working in column A1 when i choose a specific year, folder has to be created automatically in location.

So far i have created folder based on current year but i am unable to create folders for past or future years using VBA. Please find below code which i am currently using now.

CODE
Sub RunOnce()


    'Run This Code Once To Set Up Your Worksheet
    ActiveSheet.DropDowns.Add(0, 2, 100, 15).Name = "cbMonth"
    Worksheets("Sheet1").Shapes("cbMonth").ControlFormat.List = _
    Array("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
    ActiveSheet.Shapes("cbMonth").ControlFormat.DropDownLines = 12
    ActiveSheet.Buttons.Add(105, 2, 120, 15).Select
        With Selection
            .Name = "Create Folder Structure"
            .OnAction = "CreateFolders"
            .Characters.Text = "Create Folder Structure"
            .Font.Color = RGB(0, 100, 200)
            .Font.Size = 11
        End With
    Range("G1").Select
    
End Sub


Sub CreateFolders()


    Dim fso, Mf, Sf
    Dim Mdt
    Dim LD As Date
    Dim Days As Integer, dt As Integer, yr As Integer
    Dim NewFolderPath As String, strdt As String, fn As String, mon As String
    Dim Path As Variant
    
    'Get the Number of Days From the Selected Month
    yr = Year(Date)
    Mdt = Format(ActiveSheet.Shapes("cbMonth").ControlFormat.Value, "00")
    mon = MonthName(Mdt, False)
    Path = InputBox("Enter Your pathe here")
    LD = DateSerial(Year(Date), Mdt, 1)
    Days = 32 - Day(LD - Day(LD) + 32)
    
    'Create the Month Folder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Mf = fso.CreateFolder(Path & "\" & mon)
    NewFolderPath = Mf.Path
    
    'Create the SubFolders Named By Number of Days
    For dt = 1 To Days
        strdt = Format(dt, "00")
        fn = strdt & "-" & Mdt & "-" & yr
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set Sf = fso.CreateFolder(NewFolderPath & "\" & fn)
    Next
    MsgBox "Operation Complete. Folders Have Been Created."
    
End Sub

Go to the top of the page
 
ADezii
post May 4 2019, 11:19 AM
Post#2



Posts: 2,461
Joined: 4-February 07
From: USA, Florida, Delray Beach


  1. I created a Demo for you that should be very close to what you are looking for. I modified the Code for a Project that I worked on awhile ago. The Year and Month are hard coded in the example but the Month you can extract from the Combo Box and the Value for Year can be retrieved in a number of ways.
  2. There is minimal Validation Code for the sake of brevity and clarity.
  3. When prompted for the PATH, I entered C:\Test but C:\Test\ will work also.
  4. For the Year and Month I specifically chose February of 2000 to make sure the Logic correctly detects a Leap Year (2000) and February has an extra Day.
  5. I won't bore you with details but simply Post the Code and the results below.
  6. Should you have any questions, feel free to ask.
  7. Code Definition:
    CODE
    On Error Resume Next
    '***************** USER DEFINED SECTION *****************
    Const conMonth = 2      'Can be derived from Combo Box
    Const conYear = 2016
    '********************************************************
    Dim strMonth As String
    Dim strPath As String
    Dim dteDate As Date
    Dim dteLastDayInMonth As Date
    Dim strNewFolderPath As String
    Dim lngCtr As Long
    Dim strBuild As String

    strMonth = MonthName(conMonth, False)   'Long Month

    strPath = InputBox$("Enter your Path here")
    'Imperative, should use an Office Dialog to retrieve PATH
    If strPath = "" Or Dir(strPath, vbDirectory) = "" Then Exit Sub
    If Right$(strPath, 1) = "\" Then      'Don't need Trailing '\'
      strPath = Left$(strPath, Len(strPath) - 1) 'Strip it
    End If

    dteDate = DateSerial(conYear, conMonth, 1)

    'Last Day in Month = Month + 1 for Current Year - 1 Day
    dteLastDayInMonth = DateSerial(conYear, conMonth + 1, 1) - 1

    'Create Folder, after DELETING Folder
    strNewFolderPath = strPath & "\" & strMonth

    MkDir strNewFolderPath

    'MsgBox dteDate & " | " & dteLastDayInMonth
    For lngCtr = dteDate To dteLastDayInMonth
      strBuild = Format$(Day(lngCtr), "00") & "-" & _
                 Format$(Month(lngCtr), "00") & "-" & conYear
      MkDir strNewFolderPath & "\" & strBuild
    Next lngCtr
  8. Results after Code Execution (Attached Graphic). This is the newly created Directory Structure under C:\Test.


Attached File(s)
Attached File  Code_Example.JPG ( 38.95K )Number of downloads: 1
 
Go to the top of the page
 
vajeeth
post May 5 2019, 02:44 AM
Post#3



Posts: 49
Joined: 29-July 16
From: Chennai, India


Hi ADezii,

Thanks for your help, it worked. You are the best.
Go to the top of the page
 
vajeeth
post May 5 2019, 04:39 AM
Post#4



Posts: 49
Joined: 29-July 16
From: Chennai, India


Hi ADezii,

I need one more help. If user did not give the month and chose only the year, then it should create all 12 months folder and create date wise sub folder of all those months.
For now i have modified the code based on below.

CODE
On Error Resume Next
'***************** USER DEFINED SECTION *****************
Set conMonth = Range("B2")
Set conYear = Range("B3")
'********************************************************
Dim strMonth As String
Dim strPath As String
Dim dteDate As Date
Dim dteLastDayInMonth As Date
Dim strNewFolderPath As String
Dim lngCtr As Long
Dim strBuild As String

strMonth = MonthName(conMonth, False)   'Long Month

strPath = InputBox$("Enter your Path here")
'Imperative, should use an Office Dialog to retrieve PATH
If strPath = "" Or Dir(strPath, vbDirectory) = "" Then Exit Sub
If Right$(strPath, 1) = "\" Then      'Don't need Trailing '\'
  strPath = Left$(strPath, Len(strPath) - 1) 'Strip it
End If

dteDate = DateSerial(conYear, conMonth, 1)

'Last Day in Month = Month + 1 for Current Year - 1 Day
dteLastDayInMonth = DateSerial(conYear, conMonth + 1, 1) - 1

'Create Folder, after DELETING Folder
strNewFolderPath = strPath & "\" & strMonth

MkDir strNewFolderPath

'MsgBox dteDate & " | " & dteLastDayInMonth
For lngCtr = dteDate To dteLastDayInMonth
  strBuild = Format$(Day(lngCtr), "00") & "-" & _
             Format$(Month(lngCtr), "00") & "-" & conYear
  MkDir strNewFolderPath & "\" & strBuild
Next lngCtr
Go to the top of the page
 
ADezii
post May 5 2019, 08:49 AM
Post#5



Posts: 2,461
Joined: 4-February 07
From: USA, Florida, Delray Beach


QUOTE
If user did not give the month and chose only the year, then it should create all 12 months folder and create date wise sub folder of all those months.
For now i have modified the code based on below.

This significantly complicates matters and should have been mentioned in your initial Post. That being said, I'll see what I can do in a day or two. A couple of questions:
  1. If only the Year was chosen (not Month), then create 12 Month Folders and Day Sub-Folders for each Month?
  2. What needs to happen if the Month was chosen and not the Year?
  3. If neither the Month nor Year was chosen, what happens?
Go to the top of the page
 
vajeeth
post May 5 2019, 01:17 PM
Post#6



Posts: 49
Joined: 29-July 16
From: Chennai, India


Hi ADezii,

Sorry for the trouble and thanks for the help. Actually i worked around a little bit and got it work. I am posting the program just in case if anybody needed the same type of answers.

CODE
Dim ParentFolder As String
Dim SubFolder As String
Dim NewPath As String
Dim FldrPicker As FileDialog
Dim Skip As Boolean
ParentFolder = Application.ActiveWorkbook.Path
For x = 1 To 12
SubFolder = Format(x, "00. ") & MonthName(x, False) & "'" & Range("B3")
NewPath = ParentFolder & "\" & SubFolder
MkDir NewPath
dteDate = DateSerial(Range("B3"), x, 1)
dteLastDayInMonth = DateSerial(Range("B3"), x + 1, 1) - 1
For lngCtr = dteDate To dteLastDayInMonth
strBuild = Format$(Day(lngCtr), "00") & "-" & _
Format$(Month(lngCtr), "00") & "-" & Range("B3")
MkDir NewPath & "\" & strBuild
Next lngCtr
Next x
Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    19th July 2019 - 01:48 AM