VBA - How to create new folder and sub folders and save the workbook

Question

I am trying to save my workbooks with a button click, that directs the workbook to 2016 folder and few region subfolders like LA, NY, Denver, Chicago (which ever location, user selects). But as moving forward, I am trying to broaden the scope of my excel tool, such that through the same button click, workbook should be able to create folders and then sub folders and save the workbook over there. for eg., currently it should create folder for 2016 and the desired "region" subfolder that the user is working. I have additionally managed the year value from the user in the worksheet which would be in cell "D11".

Any help is much appreciated. Thanks a lot !

 location = Range("D9").Value
 FileName1 = Range("D3").Value

  If location = "Chicago" Then

     ActiveWorkbook.SaveAs FileName:="S:\Audits\2016\Chicago - 07\" & FileName1 & "-" & "Audit checklist" & ".xlsm"

     ElseIf location = "Los Angeles" Then
     ActiveWorkbook.SaveAs FileName:="S:\Audits\2016\Los Angeles\" & FileName1 & "-" & "Audit checklist" & ".xlsm"

     ElseIf location = "New York" Then
     ActiveWorkbook.SaveAs FileName:="S:\Audits\2016\New York - 08\" & FileName1 & "-" & "Audit checklist" & ".xlsm"

     Else
     ActiveWorkbook.SaveAs FileName:="S:\Audits\2016\Atlanta\" & FileName1 & "-" & "Audit checklist" & ".xlsm"

Martin Dreher Martin Dreher · Accepted Answer · 2017-01-12T15:30:09

How about this: you split your Path into an Array, loop the array, and create the subfolders with a separate routine if they do not exist

Sub test

    Dim arrFolders() As String
    Dim item As Variant
    Dim SubFolder As String

    ' In my case, ![Outfile.Parentfolder] is my Path which i get from a recordset. Adjust this to your liking
    arrFolders = Split(![OutFile.ParentFolder], Application.PathSeparator)

    SubFolder = vbNullString

    For Each item In arrFolders
        SubFolder = SubFolder & item & Application.PathSeparator
        If Not FolderExists(SubFolder) Then FolderCreate (SubFolder)
    Next item

    ' ....

End Sub

This utilizes the following two functions to to check if a folder exists and to create a folder:

' This needs a reference to microsoft scripting runtime 
Function FolderCreate(ByVal path As String) As Boolean

FolderCreate = True
    Dim fso As New FileSystemObject

try:
    If fso.FolderExists(path) Then
        Exit Function
    Else
        On Error GoTo catch
        fso.CreateFolder path
        Debug.Print "FolderCreate: " & vbTab & path
        Exit Function
    End If

catch:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    FolderCreate = False
    Exit Function

End Function

Function FolderExists(ByVal path As String) As Boolean

    FolderExists = False
    Dim fso As New FileSystemObject

    If fso.FolderExists(path) Then FolderExists = True

End Function

VBA - How to create new folder and sub folders and save the workbook

1 Answers