VBA 检查和创建文件夹系统并保存文件的代码

Question

我正在寻找一个代码，它采用一个活动工作表，一旦完成并选择一个按钮，它就会根据多个单元格值将其保存为文件夹/子文件夹系统中的新工作簿。有些单元格可能保持不变，但其他单元格可能会发生变化，从而提供各种可能已经存在或根本不存在的潜在路径。

我已经设法将一个代码放在一起，它就是这样做的，但是当我更改其中一个单元格值时，最终会稍微改变路径，我收到以下错误：运行-time error 75 : Path/File 访问错误。

我假设它与某些文件夹和子文件夹已经存在有关。不确定。

Sub Check_CreateFolders_YEAR_SO_WODRAFT()

    Dim wb As Workbook
    Dim Path1 As String
    Dim Path2 As String
    Dim Path3 As String
    Dim Path4 As String
    Dim myfilename As String
    Dim fpathname As String

    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("Jobs Sheet").Copy Before:=wb.Sheets(1)
    Path1 = "C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board"
    Path2 = Range("A23")
    Path3 = Range("I3")
    Path4 = Range("I4")
    myfilename = Range("I3").Value & Range("A1").Value & Range("I4").Value & Range("A1").Value & Range("AA1").Value
    fpathname = Path1 & "\" & Path2 & "\" & Path3 & "\" & Path4 & "\" & myfilename & ".xlsx"

    If Dir("C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 & "\" & Path3 & "\" & Path4, vbDirectory) = "" Then
        MkDir Path:="C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2
        MkDir Path:="C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 & "\" & Path3
        MkDir Path:="C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 & "\" & Path3 & "\" & Path4
        MsgBox "Completed"
    Else
        MsgBox "Sales Order Folder Already Exists so we'll save it in there"
    End If

    MsgBox "You are trying to save the file to:" & vbCrLf & fpathname
    wb.SaveAs filename:=fpathname & ".xlsx"

End Sub

理想情况下，预期结果是根据单元格值创建文件夹系统。如前所述，部分路径可能已经存在，但代码需要确定路径是否发生变化以及路径发生变化的位置，然后创建正确的路径以保存新文件。

Answer 1

使用下面的API function创建目录然后你就不必为路径已经部分存在或根本不存在而烦恼。

Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
  ByVal lpPath As String) As Long

你可以这样调用函数

MakeSureDirectoryPathExists "C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2

只需确保 Path2 以 \ 结尾，因为

If the final component of the path is a directory, not a file name, the string must end with a backslash character.

更新：这应该是带有API函数的代码

Option Explicit

Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
  ByVal lpPath As String) As Long

Sub Check_CreateFolders_YEAR_SO_WODRAFT()

    Dim wb As Workbook
    Dim Path1 As String
    Dim Path2 As String
    Dim Path3 As String
    Dim Path4 As String
    Dim myfilename As String
    Dim fpathname As String

    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("Jobs Sheet").Copy Before:=wb.Sheets(1)
    Path1 = "C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board"
    Path2 = Range("A23")
    Path3 = Range("I3")
    Path4 = Range("I4")
    myfilename = Range("I3").Value & Range("A1").Value & Range("I4").Value & Range("A1").Value & Range("AA1").Value
    fpathname = Path1 & "\" & Path2 & "\" & Path3 & "\" & Path4 & "\" & myfilename & ".xlsx"

    If Dir("C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 & "\" & Path3 & "\" & Path4, vbDirectory) = "" Then
        MakeSureDirectoryPathExists "C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 & "\" & Path3 & "\" & Path4 & "\"
        ' MkDir Path:="C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 
        ' MkDir Path:="C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 & "\" & Path3
        ' MkDir Path:="C:\Users\jackson.wills\Sparter Ltd\Engineer Order - e-Board\" & Path2 & "\" & Path3 & "\" & Path4
        MsgBox "Completed"
    Else
        MsgBox "Sales Order Folder Already Exists so we'll save it in there"
    End If

    MsgBox "You are trying to save the file to:" & vbCrLf & fpathname
    wb.SaveAs Filename:=fpathname & ".xlsx"

End Sub

VBA 检查和创建文件夹系统并保存文件的代码

VBA code to check and create folder system and save file

directory

excel

vba

path

save-as