VBA Create subfolders and name them based on cell value

[rplohocky]

Hello,
I need to have a macro create a new folder in 8 other folders and name them based on what is in cell A168 from the workbook that holds the macro.

Once a person clicks on the button to process the macro, the macro should look in cell A168 and create new folder in each of the 8 main folders. The folder locations are:

\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Inventory\
\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Order Status\
\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Pars - Active Moves\
\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Pars - Storage\
\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Remarketing Data\
\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Renewal Status\
\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Tag Expiration\
\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Violations\

The macro would look at cell A168 and then add a folder into each of these locations.
Here is the code I use now to create a new folder in each of these folders. The issue is there is a pop up saying it has created a new folder 8 times. I'm just trying to reduce the macro size but accomplish the same thing.

Sub MakeMyFolderInventory()
'This macro creates a new folder based on what is in cells A168 in the Inventory folder.
    Dim fdObj As Object
    Application.ScreenUpdating = False
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists("\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Inventory\" & [A168]) Then
        MsgBox "Your folder is already here and ready!.", vbInformation, "Your folder is found!"
    Else
        fdObj.CreateFolder ("\\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Inventory\" & [A168])
        MsgBox "Your new folder has been created.", vbInformation, "Create a new folder!"
    End If
    Application.ScreenUpdating = True
    
'Below opens a folder where your invoices will be stored.
    Dim retVal As Long
    retVal = Shell("explorer.exe \\fleet.ad\data\Data1\VMSSHARE\FS\FPSCOEASSO\Temporary Fleet Reports\313670 Avanir\Inventory\" & [A168], vbNormalFocus)
        
    End Sub

 

[PatOBrien198]

If you don't like the pop-ups, just comment out the "MsgBox" lines (put an apostrophe (') in front of it)

If you've got a separate sub routine for each then maybe you replace them all with:

assumes that your folder names start in cell B168.

Sub DoNextFolder()

Dim r As Integer
Dim rng As Range
Set rng = Range("B168")
r = 0
Do While rng.Offset(r, 0) <> ""
   Call MakeMyFolder(rng.Offset(r, 0))
   r = r + 1
Loop
End Sub


Sub MakeMyFolder(NewPath As String)
'This macro creates a new folder based on what is in cells A168
    Dim fdObj As Object
    Application.ScreenUpdating = False
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists(NewPath & [A168]) Then
        MsgBox "Your folder is already here and ready!.", vbInformation, "Your folder is found!"
    Else
        fdObj.CreateFolder (NewPath & [A168])
        MsgBox "Your new folder has been created.", vbInformation, "Create a new folder!"
    End If
    Application.ScreenUpdating = True
    
'Below opens a folder where your invoices will be stored.
    Dim retVal As Long
    retVal = Shell("explorer.exe " & NewPath & [A168], vbNormalFocus)
        
    End Sub
End Sub

NOTE: I did NOT test this.

 

[rplohocky]

If you don't like the pop-ups, just comment out the "MsgBox" lines (put an apostrophe (') in front of it)

If you've got a separate sub routine for each then maybe you replace them all with:

assumes that your folder names start in cell B168.

Sub DoNextFolder()

Dim r As Integer
Dim rng As Range
Set rng = Range("B168")
r = 0
Do While rng.Offset(r, 0) <> ""
   Call MakeMyFolder(rng.Offset(r, 0))
   r = r + 1
Loop
End Sub


Sub MakeMyFolder(NewPath As String)
'This macro creates a new folder based on what is in cells A168
    Dim fdObj As Object
    Application.ScreenUpdating = False
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists(NewPath & [A168]) Then
        MsgBox "Your folder is already here and ready!.", vbInformation, "Your folder is found!"
    Else
        fdObj.CreateFolder (NewPath & [A168])
        MsgBox "Your new folder has been created.", vbInformation, "Create a new folder!"
    End If
    Application.ScreenUpdating = True
    
'Below opens a folder where your invoices will be stored.
    Dim retVal As Long
    retVal = Shell("explorer.exe " & NewPath & [A168], vbNormalFocus)
        
    End Sub
End Sub

NOTE: I did NOT test this.

Hello PatObrien198,
I don't see how this code would know where to make the folders. There are no directory addresses so the macro know where to make the folder. Am I missing something?

 

[PatOBrien198]

The directory addresses or folder names (in the macro) are assumed to start in cell B168 of the active sheet. You could make this anything you want. The macro reads the folder names from the sheet and calls the generic MakeMyFolder subroutine, passing the folder name as an argument.

Make sure that the folder names end with a back-slash.

 

[rplohocky]

The directory addresses or folder names (in the macro) are assumed to start in cell B168 of the active sheet. You could make this anything you want. The macro reads the folder names from the sheet and calls the generic MakeMyFolder subroutine, passing the folder name as an argument.

Make sure that the folder names end with a back-slash.

Hello PatObrien198,
I think I need to explain further. The name of the new folder will always be just in cell A168. The name will be the current date like "July-4-2018". In cells C176 through C183 are the names of each of the folders that the above folder would need to be created. Each of the folders would have a new folder named "July-4-2018" in them. I can't see in your code how it would know to insert a new folder with the same name into each of the folders named in the range C176 thru C183. I should have explained this better, my fault. Its no big deal if you don't respond, I can make what I have work I was just trying to reduce macro size.

 

[PatOBrien198]

The Do-Loop below reads the main folder names and passes the name to the subroutine that makes the new folder using the value in cell A168.

Set rng = Range("C176")
r = 0
Do While rng.Offset(r, 0) <> ""
   Call MakeMyFolder(rng.Offset(r, 0))
   r = r + 1
Loop
End Sub

Try stepping thru the code line by line to (F8) to see what it is doing.