Sunday, August 12, 2012

Excel Create Folder Macro Updated

Today I’m going to revisit how to create a folder in Excel. There’s been some good discussion on my earlier post about to use an Excelmacro to automatically create folders. My original version only created folders in the same file where the Excel spreadsheet was saved. After some reader questions and collaboration we’ve created a new version which allows you to browse to the directory location where you would like the VBA macro to automatically create all the folders you have listed and selected in the Excel workbook.

A reminder of how the Excel macro creates folders. Make your list of folders in any column in a worksheet (which does NOT have to be saved like in previous versions). Select the range of names you want to create. Run the macro.

To open a folder browser with an Excel macro we need to create a shell application object using this code:  

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

I put together a short video showcasing the end result and how the Excel VBA create folder macro should work. Also, if you’re looking to build your own website watch the video to get a 25% off coupon for Host Gator.


The complete code is listed below. Now you can show your bosses and coworkers how to make a folder with Excel. Please join our newsletter for more Excel tips.


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

'create the folders where-ever the workbook is saved
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count

For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (BrowseForFolder & "\" & Rng(r, c))

On Error Resume Next
End If
r = r + 1
Loop

Next c
End Sub
 

Create Folders.xlsm Download