VBA - 如何创建新文件夹和子文件夹并保存工作簿答案

【问题标题】：VBA - How to create new folder and sub folders and save the workbookVBA - 如何创建新文件夹和子文件夹并保存工作簿
【发布时间】：2017-01-12 15:16:56
【问题描述】：

我正在尝试通过单击按钮来保存我的工作簿，这会将工作簿定向到 2016 文件夹和几个区域子文件夹，例如 LA、NY、Denver、Chicago（用户选择哪个位置）。但随着前进，我正在尝试扩大我的 excel 工具的范围，以便通过相同的按钮单击，工作簿应该能够创建文件夹，然后创建子文件夹并将工作簿保存在那里。例如，目前它应该为 2016 创建文件夹和用户正在工作的所需“区域”子文件夹。我还在工作表中管理了来自用户的年份值，该工作表位于单元格“D11”中。

非常感谢任何帮助。非常感谢！

 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"

【问题讨论】：

标签： excel vba

【解决方案1】：

这个怎么样：你将你的路径分割成一个数组，循环数组，如果子文件夹不存在，则使用单独的例程创建子文件夹

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 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

【讨论】：