Creating Sub Folders using VBA

[breitnet]

Hello All, I am looking for some help creating sub folders in a VBA Macro. I have code the allows me to browse where to create a folder using the cell value as the name. What I would like to do is create another sub folder under the previously selected folder, named from a new cell value.

'Sub Create_Folders()

penAt = "My computer:"

Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.Self.Path

'new folder location
Dim Rng As Range
Set Rng = Sheet1.Cells(100, 8).Value

'create folder in selected directory
If Sheet1.Cells(100, 8).Value <> "" Then
MkDir (BrowseForFolder & "" & Sheet1.Cells(100, 8).Value)

 

[Fluff]

Hi & welcome to the board.

I assume that you code isn't working, in which case what isn't working & do you get any errors?

 

[breitnet]

Hi & welcome to the board.

I assume that you code isn't working, in which case what isn't working & do you get any errors?

The code listed does work. It opens a window that allows me to browse to a folder location and select. Then creates a new folder (folder1) based on cell value.

What I am trying to do is capture folder1 location selected, write the folder1 path to a new cell and create a sub folder under folder1.

 

[Fluff]

Something like

Sub Create_Folders()

openAt = "My computer:"

Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, openAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.Self.path

'new folder location
Dim Rng As Range
Set Rng = Sheet1.Cells(100, 8).Value

'create folder in selected directory
If Sheet1.Cells(100, 8).Value <> "" Then
Sheet1.Cells(100, 9).Value = BrowseForFolder & "\" & Sheet1.Cells(100, 8).Value
MkDir (BrowseForFolder & "\" & Sheet1.Cells(100, 8).Value)
MkDir (Sheet1.Cells(100, 9).Value & "\" & Sheet1.Cells(101, 8).Value)
End If
End Sub

 

[breitnet]

Something like

Sub Create_Folders()

openAt = "My computer:"

Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, openAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.Self.path

'new folder location
Dim Rng As Range
Set Rng = Sheet1.Cells(100, 8).Value

'create folder in selected directory
If Sheet1.Cells(100, 8).Value <> "" Then
Sheet1.Cells(100, 9).Value = BrowseForFolder & "\" & Sheet1.Cells(100, 8).Value
MkDir (BrowseForFolder & "\" & Sheet1.Cells(100, 8).Value)
MkDir (Sheet1.Cells(100, 9).Value & "\" & Sheet1.Cells(101, 8).Value)
End If
End Sub

Thank you...worked excellent!

 

[Fluff]

Glad to help & thanks for the feedback

 

[breitnet]

Glad to help & thanks for the feedback

I also have another macro I am working on if you could help. I am trying to copy files from one folder to another folder based on a partial file name.

Here is the code I am currently using. It copies the entire contents of the folder.


Private Sub CommandButton2_Click()
'copy files into folder
Dim FSO As Object
Dim sourcePath As String
Dim DestinationPath As String
Dim fileExtn As String

sourcePath = Sheet1.Cells(121, 9).Value
DestinationPath = Sheet1.Cells(110, 13).Value
fileExtn = "*.mpf"
If Right(sourcePath, 1) <> "" Then
sourcePath = sourcePath & ""
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.folderExists(sourcePath) = False Then
MsgBox sourcePath & "does not exist"
Exit Sub
End If
If FSO.folderExists(DestinationPath) = False Then
MsgBox DestinationPath & "does not exist"
Exit Sub
End If
FSO.copyfile Source:=sourcePath & fileExtn, Destination:=DestinationPath
MsgBox "Your files have been copied"

End Sub

 

[Fluff]

As this is a completely different question, could you please start a new thread.
Also, when posting code could you please use the code tags (the # icon in the reply window)

 

[CoolAuto]

Hi, As a follow up to your awesome solution - How to modify my code below to create 12 sub-folders based on values in range A2:A13? My last line of code before End If is not doing it (guessing some loop is needed...)

Sub Create12Folders()


openAt = Sheet1.Cells(1, 3).Value


Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, openAt)


'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.Self.Path


'new folder location
Dim Rng As Range
Set Rng = Sheet1.Cells(1, 1).Value


'create folder in selected directory
If Sheet1.Cells(1, 1).Value <> "" Then '1A
Sheet1.Cells(1, 2).Value = BrowseForFolder & "\" & Sheet1.Cells(1, 1).Value 'PRINTS PATH INTO B1 OF FOLDER NAVIGATED TO & VALUE IN A1
MkDir (BrowseForFolder & "\" & Sheet1.Cells(1, 1).Value) 'MAKES FOLDER IN FOLDER NAVIGATED TO NAMED WITH VALUE IN A1
MkDir (Sheet1.Cells(1, 2).Value & "\" & Range(Cells(2, 1), Cells(13, 1)).Value) 'need to create 12 subfolders based on values in range A2:A13
End If
End Sub

 

[Fluff]

Is this what you want?

Sub Create12Folders()


openAt = Sheet1.Cells(1, 3).Value


Set shellapp = CreateObject("Shell.Application").BrowseForFolder(0, "Please Choose The Folder For This Project", 0, openAt)


'Set the folder to that selected. (On error in case cancelled)
'On Error Resume Next
BrowseForFolder = shellapp.Self.Path


'new folder location
Dim Cl As Range
Dim Rng As Range
Set Rng = Sheet1.Cells(1, 1)
   If Rng <> "" Then '1A
      Rng.Offset(, 1).Value = BrowseForFolder & "\" & Rng.Value 'PRINTS PATH INTO B1 OF FOLDER NAVIGATED TO & VALUE IN A1
      MkDir (BrowseForFolder & "\" & Rng.Value) 'MAKES FOLDER IN FOLDER NAVIGATED TO NAMED WITH VALUE IN A1
   End If

For Each Cl In Sheet1.Range("A2:A13")
   'create folder in selected directory
   If Cl.Value <> "" Then '1A
      MkDir (Rng.Offset(, 1).Value & "\" & Cl.Value) 'need to create 12 subfolders based on values in range A2:A13
   End If
Next Cl
End Sub