Код VBA для проверки и создания системы папок и сохранения файла - PullRequest
Новая
       41

Код VBA для проверки и создания системы папок и сохранения файла

0 голосов
/ 31 октября 2019

Я хочу создать код, который берет активный лист, который после заполнения и выбора кнопки сохраняет его как новую книгу в системе папок / подпапок на основе нескольких значений ячеек. Некоторые из ячеек могут остаться прежними, но другие могут измениться, давая множество потенциальных путей, которые могли бы уже существовать или не существовать вообще.

Мне удалось собрать воедино код, который делает именно это, но когда я изменяю одно из значений ячейки, что в конечном итоге слегка меняет путь, я получаю следующую ошибку: Ошибка времени выполнения 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

Ожидаемые результаты в идеале должны быть созданы для системы папок на основе значений ячеек. Как упоминалось ранее, часть пути может уже существовать, но код должен определить, если и где путь изменяется, затем создать правильный путь и затем сохранить новый файл.

1 Ответ

0 голосов
/ 31 октября 2019

Используйте следующую API-функцию для создания директивы, тогда вам не нужно беспокоиться, если путь уже частично существует или не существует вообще. 

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 заканчивается \, потому что

ЕслиПоследний компонент пути - это каталог, а не имя файла, строка должна заканчиваться символом обратной косой черты.

Обновление: Это должен быть код с функцией 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
...