VBA代码检查和创建文件夹系统并保存文件 [英] 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.

我已经设法将代码组合在一起，但是这样做时，当我更改一个单元格值(最终最终略微更改了路径)时，出现以下错误:运行时错误75:路径/文件访问错误

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.

推荐答案

使用以下 API函数创建目录，则无需麻烦，如果路径已经部分存在或根本不存在.

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

您将这样调用函数

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函数的代码

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

这篇关于VBA代码检查和创建文件夹系统并保存文件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！