VBA code to check and create folder system and save file

问题

I'm looking to create a code that takes an active worksheet which once completed and a button is selected it saves it as a new workbook within a folder / subfolder system based on multiple cell values. Some of the cells may stay the same but others may change, giving a variety of potential paths which could already part exist or not exist at all.

I've managed to put a code together which does just that but when I change one of the cell values, which ultimately changes the path slightly, I get the following error: Run-time error 75: Path/File access error.

I'm assuming its something to do with some folders and subfolders already exist. Not sure.

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

Expected results would ideally be for a folder system to be created based on the cell values. As mentioned previously, part of the path may already exist but the code needs to identify if and where the path changes to then create the correct path to then save the new file.

回答1:

Use the following API function to create the directoy then you do not have to bother if the path already partly exists or does not exist at all.

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

You would call the function like that

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

Just make sure that Path2 ends with a \ because

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

Update: This should be the code with the 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

来源：https://stackoverflow.com/questions/58640658/vba-code-to-check-and-create-folder-system-and-save-file

标签

excel

vba