'=============================================================================
'- MAKE MULTIPLE NEW FOLDERS
'- Makes a new folder in each subfolder of the specified Base folder
'-----------------------------------------------------------------------------
'- THERE IS A OPTION TO ADD NEW FOLDERS TO SUBFOLDERS TOO
'- USE EXTREME CARE WITH THIS ONE.
'- IT WILL USE *EVERY* FOLDER AND SUBFOLDER IN THE BASE FOLDER
'- ......... except of the same name (eg. cannot make \TEST\TEST)
'-----------------------------------------------------------------------------
'- Brian Baulsom July 2010
'=============================================================================
'- SET VARIABLES
Const BaseFolder As String = "F:\test" ' BASE FOLDER (no final backslash)
Const AddToSubFoldersToo As Boolean = False
Const NewFolderName As String = "TEST" ' NAME FOR THE NEW FOLDER
'==============================================================================
'- FileSystemObject
Dim FSO As Object
Dim FolderName As String
Dim FolderSpec As String
Dim FolderCount As Long
'------------------------------------------------------------------------------
'=============================================================================
'- MAIN ROUTINE
'=============================================================================
Sub MAKE_FOLDERS()
rsp = MsgBox("Base Folder : " & BaseFolder & vbCr _
& "Add subfolders ?" & vbCr _
& "New Folder : " & NewFolderName, vbOKCancel)
If rsp = vbCancel Then Exit Sub
'-------------------------------------------------------------------------
'- INITIALISE
Set FSO = CreateObject("Scripting.FileSystemObject") ' FILE SYSTEM OBJECT
Application.Calculation = xlCalculationManual
FolderCount = 0
'==========================================================================
'- CALL FOLDER SUBROUTINE
GetSubFolders (BaseFolder)
'==========================================================================
'- FINISH
MsgBox ("Made " & FolderCount & " new folders.")
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub
'======== END OF MAIN ROUTINE =================================================
'===============================================================================
'- SUBROUTINE 1 : GET SUBFOLDERS
'- Called from Main routine and also calls itself
'===============================================================================
Private Sub GetSubFolders(FolderSpec)
Dim F, f1, fc, s
Set F = FSO.GetFolder(FolderSpec)
Set fc = F.SubFolders
'--------------------------------------------------------------------------
'- CHECK SUBFOLDER COUNT
If fc.Count = 0 Then
'There are no sub folders in (FolderSpec)
Exit Sub
Else
'- LOOP FOLDERS
For Each f1 In fc
FolderName = f1.path
'==================================================================
MAKE_NEW_FOLDER FolderName ' CALL MkDir() SUBROUTINE
'==================================================================
'- CALL SELF TO GET SUBFOLDERS
If AddToSubFoldersToo = True Then
GetSubFolders (FolderName) ' CALLS ITSELF
End If
'==================================================================
Next
End If
'--------------------------------------------------------------------------
End Sub
'==============================================================================
'==============================================================================
'-SUBROUTINE 2 : CALLED FROM SUBROUTINE 1 : MAKE A NEW FOLDER
'==============================================================================
Private Sub MAKE_NEW_FOLDER(CurrentFolder)
Dim NewFolder As String, n
'-------------------------------------------------------------------------
'- IGNORE NEW FOLDER ALREADY ADDED
If Right(CurrentFolder, Len(NewFolderName)) = NewFolderName Then Exit Sub
NewFolder = CurrentFolder & "\" & NewFolderName
'-------------------------------------------------------------------------
'- CODE FOR TESTING (comment out when working as required)
rsp = MsgBox("Current Folder : " & CurrentFolder & vbCr _
& "Make new '" & NewFolderName & "' folder ?", vbOKCancel)
If rsp = Cancel Then Exit Sub
'-------------------------------------------------------------------------
'- MAKE THE FOLDER
On Error Resume Next
MkDir NewFolder
If Err.Number <> 0 Then
'There is already a folder (NewFolderName)
Exit Sub
Else
FolderCount = FolderCount + 1
Application.StatusBar = FolderCount & " : " & FolderName
End If
'-------------------------------------------------------------------------
End Sub
'==============================================================================
