Setup of new folders

[Barefoot]

Hi there

Need some help please on a time saving exercise.

What I would like is a routine that will create new (sub?) folders for each month or period for me in a specified/selected folder.
The new folders to be created are either monthly (1 - Apr 0x to 12 - Mar 0x), or by period (Period 1 to Period 12).

You probably noticed, but our financial year runs April to March and I hope to be able to use this routine to setup all the new years folders.

I assume that this would run from excel.

Thanks

 

[Jaafar Tribak]

How about this ?

Option Explicit

Private Sub CreateSubfolders(strParentFolder As String, ParamArray SubFolders() As Variant)

    Dim sSubFolderPathName As String, vSubFolder As Variant
    
    If Right(strParentFolder, 1) <> "\" Then
        strParentFolder = strParentFolder & "\"
    End If
    For Each vSubFolder In SubFolders
        sSubFolderPathName = strParentFolder & vSubFolder
        VBA.MkDir (sSubFolderPathName)
    Next

End Sub


Sub test()

    CreateSubfolders "C:\", "Period1", "Period2", "Period3"  '...ect

End Sub

Regards.

 

[Barefoot]

Hi Jaafar

Thanks for that it works well.

Is there a method? that you could use to select the folder to add the new folders to?

Cheers
Julian

 

[Jaafar Tribak]

Is this what you need ?

Option Explicit

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Type BROWSEINFO
    HwndOwner As Long
    PidlRoot As Long
    PszDisplayName As String
    LpszTitle As String
    UlFlags As Long
    Lpfn As Long
    lParam As Long
    IImage As Long
End Type

Private Function GetFolder() As String

    Dim Info As BROWSEINFO
    Dim lPID As Long, sPath As String
    Dim sFolderPath As String
    Const BIF_RETURNONLYFSDIRS = &H1
    
    Info.LpszTitle = "Select Folder:"
    Info.UlFlags = BIF_RETURNONLYFSDIRS
    lPID = SHBrowseForFolder(Info)
    sPath = Space$(512)
    If (SHGetPathFromIDList(lPID, sPath)) Then
        sFolderPath = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
        GetFolder = sFolderPath
    End If
    
End Function

Private Sub CreateSubfolders(strParentFolder As String, ParamArray SubFolders() As Variant)

    Dim sSubFolderPathName As String, vSubFolder As Variant
    
    If Right(strParentFolder, 1) <> "\" Then
        strParentFolder = strParentFolder & "\"
    End If
    For Each vSubFolder In SubFolders
        sSubFolderPathName = strParentFolder & vSubFolder
        VBA.MkDir (sSubFolderPathName)
    Next

End Sub

Run this routine :

Sub test()

    Dim sParentFolder As String
    
    sParentFolder = GetFolder
    If Len(sParentFolder) <> 0 Then
        CreateSubfolders sParentFolder, "Period1", "Period2", "Period3"  '...ect
    End If

End Sub

Regards.

 

[Barefoot]

Jaafar

Exactly.

Thanks a million.

Cheers
Julian