用于检查和创建文件夹系统以及保存文件的VBA代码

Question

我想创建一个代码，它接受一个活动工作表，一旦完成并选择了一个按钮，它就会根据多个单元格值将其保存为文件夹/子文件夹系统中的新工作簿。一些细胞可能保持不变，但其他细胞可能发生变化，从而产生各种可能已经部分存在或根本不存在的潜在路径。

我已经成功地编写了一个代码，可以做到这一点，但当我更改其中一个单元格值时，最终会稍微更改路径，我会得到以下错误：运行时错误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:Usersjackson.willsSparter LtdEngineer 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:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2 & "" & Path3 & "" & Path4, vbDirectory) = "" Then
MkDir Path:="C:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2
MkDir Path:="C:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2 & "" & Path3
MkDir Path:="C:Usersjackson.willsSparter LtdEngineer 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函数来创建directoy，然后如果路径已经部分存在或根本不存在，则不必麻烦。

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

你可以调用类似的函数

MakeSureDirectoryPathExists "C:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2

只需确保Path2以结束，因为

如果路径的最后一个组件是目录，而不是文件名，则字符串必须以反斜杠字符结束。

更新：这应该是带有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:Usersjackson.willsSparter LtdEngineer 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:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2 & "" & Path3 & "" & Path4, vbDirectory) = "" Then
MakeSureDirectoryPathExists "C:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2 & "" & Path3 & "" & Path4 & ""
' MkDir Path:="C:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2 
' MkDir Path:="C:Usersjackson.willsSparter LtdEngineer Order - e-Board" & Path2 & "" & Path3
' MkDir Path:="C:Usersjackson.willsSparter LtdEngineer 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