VBA 代碼檢查和創建文件夾系統並保存文件

Question

我正在尋找一個代碼，該代碼采用一個活動工作表，一旦完成並選擇一個按鈕，它將根據多個單元格值將其保存為文件夾/子文件夾系統中的新工作簿。 一些單元格可能保持不變，但其他單元格可能會發生變化，從而提供可能已經部分存在或根本不存在的各種潛在路徑。

我已經設法將一個代碼放在一起，但是當我更改其中一個單元格值時，最終會稍微改變路徑，我收到以下錯誤：運行時錯誤 75：路徑/文件訪問錯誤。

我假設它與一些文件夾和子文件夾已經存在有關。 沒有把握。

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

你會這樣稱呼 function

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

只要確保Path2以\結尾，因為

如果路徑的最后部分是目錄，而不是文件名，則字符串必須以反斜杠字符結尾。

更新：這應該是 API function 的代碼

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