Create Sub Folder within Main Folders

[hkydad]

Hi...
I have a list of folders on the network but I need to add a subfolder to them. Each main folder will be getting the same sub-folder. Below is the code I am currently using to create the main folders. How do I create the same sub folder in each of these folders. Thank you in advance for your assistance.

Sub CreateFolders()


Dim xdir As String
Dim fso
Dim fsoSub
Dim lstrow As Long
Dim i As Long
Dim xdirsubfolder As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsoSub = CreateObject("Scripting.FileSystemObject")
lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = True
For i = 1 To lstrow
xdir = "J:\_Dvision\Group\Tim\2024\" & Range("A" & i).Value
xdirsubfolder = "J:\_Division\Group\Tim\2024\" & Range("A" & i).Value & "\" & Range("A" & i).Offset(0, 3)

If Not fso.FolderExists(xdir) Then
fso.CreateFolder (xdir)
End If

If Not fsoSub.FolderExists(xdirsubfolder) Then
fsoSub.CreateFolder (xdirsubfolder)
End If


Next
Application.ScreenUpdating = True
End Sub

 

[Domenic]

Are you getting an error? If so, which one and on which line?

Or is your code not creating subfolders within the main folders?

A couple of things, though...

1) You have a spelling mistake in the path assigned to xdir. It looks like it should be Division, not Dvision...

xdir = "J:\_Division\Group\Tim\2024\" & Range("A" & i).Value

2) There's no need to create two FileSystemObject objects. You only need to create the object once.

3) Since you're going to be creating a lot of folders and subfolders, which requires a lot of processing, use DoEvents after each time that you create one. DoEvents passes control to the operating system, and returns after the folder or subfolder has been created (and other events have been processed).

I haven't tested it, but maybe something like this...

Option Explicit

Sub CreateFolders()

    Dim fso As Object
    Dim xdir As String
    Dim xdirsubfolder As String
    Dim lstrow As Long
    Dim i As Long
   
    Application.ScreenUpdating = True
   
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
   
    For i = 1 To lstrow
        xdir = "J:\_Division\Group\Tim\2024\" & Range("A" & i).Value
        xdirsubfolder = xdir & "\" & Range("A" & i).Offset(0, 3).Value
        If Not fso.folderexists(xdir) Then
            fso.createfolder xdir
            DoEvents
            fso.createfolder xdirsubfolder
            DoEvents
        ElseIf Not fso.folderexists(xdirsubfolder) Then
            fso.createfolder xdirsubfolder
            DoEvents
        End If
    Next i
   
    Application.ScreenUpdating = True
   
End Sub

Hope this helps!

 

[hkydad]

Are you getting an error? If so, which one and on which line?

Or is your code not creating subfolders within the main folders?

A couple of things, though...

1) You have a spelling mistake in the path assigned to xdir. It looks like it should be Division, not Dvision...

xdir = "J:\_Division\Group\Tim\2024\" & Range("A" & i).Value

2) There's no need to create two FileSystemObject objects. You only need to create the object once.

3) Since you're going to be creating a lot of folders and subfolders, which requires a lot of processing, use DoEvents after each time that you create one. DoEvents passes control to the operating system, and returns after the folder or subfolder has been created (and other events have been processed).

I haven't tested it, but maybe something like this...

Option Explicit

Sub CreateFolders()

    Dim fso As Object
    Dim xdir As String
    Dim xdirsubfolder As String
    Dim lstrow As Long
    Dim i As Long
 
    Application.ScreenUpdating = True
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
 
    For i = 1 To lstrow
        xdir = "J:\_Division\Group\Tim\2024\" & Range("A" & i).Value
        xdirsubfolder = xdir & "\" & Range("A" & i).Offset(0, 3).Value
        If Not fso.folderexists(xdir) Then
            fso.createfolder xdir
            DoEvents
            fso.createfolder xdirsubfolder
            DoEvents
        ElseIf Not fso.folderexists(xdirsubfolder) Then
            fso.createfolder xdirsubfolder
            DoEvents
        End If
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

Hope this helps!

Thank you for this code. When I run the code, I am getting a 'Run-time error '76': Path not found' when it gets to the first fso.CreateFolder xdir. What am I missing? I have the main folder name in A1 and the name of the sub folder in A2.

I have also tried putting the name of the main folder followed by a \ and the name of the sub-folder in A1 but am getting the same error message.

01 2024\Ltrs

 

[Domenic]

Try running the macro again. This time, though, when the error occurs, click on Debug so that it takes you to the line causing the error. Then enter the following line of code in the Immediate Window (Ctrl-G), and press ENTER...

? xdir

Does it return a valid path?

 

[hkydad]

The ? xdir returned a valid path but for some reason the code did not like the last part of the directory where I wanted the folders to be setup - "....\Tim\2024\' but once I removed the \2024\ piece, the code ran to perfection.

Thank you for your assistance

 

[Domenic]

Glad you've sorted it out.

Cheers!