Hello everyone. I recently developed some script which will produce a series of folders based on a user inputing a date that it is enetered in a message box using the dd-mmm-yyyy format. The date that is entered is always the last day of a quarter. So for example it will be one of the following:

i. March 31
ii. June 30
iii. September 30
iv. December 31

Now what I have are four folders labeled

1. 1 Quarter
2. 2 Quarter
3. 3 Quarter
4. 4 Quarter

And here is where I am stuck If the user enters a date of say 30-Jun-2010 as you can see form the code below it will produce the following:

A. a folder labeled 30-Jun-2010...and some subfolders
B. a folder labeled 31-May-2010...and some subfolders
C. a folder labeled 30-Apr-2010...and some subfolders

Now what I cannot fogure out is how to take A,B and C and place them into the 2 Quarter folder. Similairyl if a user enters the date of 31-Mar-2010 then the folders that are created by the script need to be put into the 1 Quarter folder...and so on. Any help is appreciated. 

Dim fDate            As String
    Dim fPath            As String
    Dim fDatePrevious1   As String
    Dim fDatePrevious2   As String
    Dim fDatePrevious3   As String
    Dim fPriorDate1      As String
    Dim fPriorDate2      As String
    Dim fPriorDate3      As String
    
    Sub CreateFolder()
'***********************************************************************
'CreateFolder() macro creates the folders for the 157 Automation process.
'***********************************************************************

    Dim Fldr   As String
    Dim ErrBuf As String

    fDate = Application.InputBox("Enter a date in the format shown:", "Date to add...", Format(Date, "DD-MMM-YYYY"))
    If fDate = "False" Then Exit Sub
    
    fDatePrevious1 = DateSerial(Year(fDate) - 1, Month(fDate), 0)
    fPriorDate1 = Format(fDatePrevious1, "DD-MMM-YYYY")
    
    fDatePrevious2 = DateSerial(Year(fDate), Month(fDate) - 1, 0)
    fPriorDate2 = Format(fDatePrevious2, "DD-MMM-YYYY")
    
    fDatePrevious3 = DateSerial(Year(fDate), Month(fDate) - 2, 0)
    fPriorDate3 = Format(fDatePrevious3, "DD-MMM-YYYY")
       
    fPath = "L:\"

    On Error GoTo ErrorHandler
        
        Fldr = fPath & fDate & "_157"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate1 & "_157"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate2 & "_157"
        MkDir Fldr
        
        Fldr = fPath & fDate & "_157\" & "157_Reports"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate1 & "_157\" & "157_Reports"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate2 & "_157\" & "157_Reports"
        MkDir Fldr
        
        Fldr = fPath & fDate & "_157\" & "157_Reports\" & "Roll_forward_wTA"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate1 & "_157\" & "157_Reports\" & "Roll_forward_wTA"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate2 & "_157\" & "157_Reports\" & "Roll_forward_wTA"
        MkDir Fldr
               
        Fldr = fPath & fDate & "_157\" & "157_Reports\" & "Terminated"
        MkDir Fldr
                      
        Fldr = fPath & fPriorDate1 & "_157\" & "157_Reports\" & "Terminated"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate2 & "_157\" & "157_Reports\" & "Terminated"
        MkDir Fldr
                      
        Fldr = fPath & fDate & "_157\" & "157_Reports\" & "IBRD_Disclosure"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate1 & "_157\" & "157_Reports\" & "IBRD_Disclosure"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate2 & "_157\" & "157_Reports\" & "IBRD_Disclosure"
        MkDir Fldr
        
        Fldr = fPath & fDate & "_157\" & "105_Reports"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate1 & "_157\" & "105_Reports"
        MkDir Fldr
        
        Fldr = fPath & fPriorDate2 & "_157\" & "105_Reports"
        MkDir Fldr
    
    If Len(ErrBuf) > 0 Then MsgBox "The following folders already existed:" & vbLf & vbLf & ErrBuf
    
    Exit Sub
    
ErrorHandler:
    ErrBuf = ErrBuf & vbLf & Fldr
    Resume Next
    
End Sub