Excel VBA Проверьте, существует ли в каталоге ошибка

У меня есть электронная таблица, которая при нажатии кнопки будет дублироваться, копируя/вставляя все в новую книгу и сохраняя файл с именем, которое зависит от некоторых значений переменных (взятых из ячеек в электронной таблице). Моя текущая цель - заставить его сохранить лист в разных папках в зависимости от имени клиента (значение ячейки удерживается в переменной), в то время как это работает при первом запуске, я получаю сообщение об ошибке после.

Код проверяет, существует ли каталог и создает его, если нет. Это работает, но после того, как он создан, его запуск второй раз вызывает ошибку:

Ошибка выполнения 75 - ошибка доступа к пути/файлу.

Мой код:

Sub Pastefile()

Dim client As String
Dim site As String
Dim screeningdate As Date
screeningdate = Range("b7").Value
Dim screeningdate_text As String
screeningdate_text = Format$(screeningdate, "yyyy\-mm\-dd")
client = Range("B3").Value
site = Range("B23").Value


Dim SrceFile
Dim DestFile

If Dir("C:\2013 Recieved Schedules" & "\" & client) = Empty Then
    MkDir "C:\2013 Recieved Schedules" & "\" & client
End If

SrceFile = "C:\2013 Recieved Schedules\schedule template.xlsx"
DestFile = "C:\2013 Recieved Schedules\" & client & "\" & client & " " & site & " " & screeningdate_text & ".xlsx"


FileCopy SrceFile, DestFile

Range("A1:I37").Select
Selection.Copy
Workbooks.Open Filename:= _
    "C:\2013 Recieved Schedules\" & client & "\" & client & " " & site & " " & screeningdate_text & ".xlsx", UpdateLinks:= _
    0
Range("A1:I37").PasteSpecial Paste:=xlPasteValues
Range("C6").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close

End Sub

Вы должны извинить мою нехватку знаний в этой области, я все еще участвую. У меня очень сильное чувство, что оно имеет какое-то отношение к логике проверки каталогов, так как при ошибке выводится строка MkDir.

Ответ 1

Чтобы проверить наличие каталога с помощью Dir, вам нужно указать vbDirectory как второй аргумент, как в чем-то вроде:

If Dir("C:\2013 Recieved Schedules" & "\" & client, vbDirectory) = "" Then

Обратите внимание, что при vbDirectory, Dir будет возвращать непустую строку, если указанный путь уже существует как каталог или файл (если файл не имеет ни одного из доступных для чтения, скрытых, или системные атрибуты). Вы можете использовать GetAttr, чтобы убедиться, что это каталог, а не файл.

Ответ 2

Используйте метод FolderExists объекта сценария.

Public Function dirExists(s_directory As String) As Boolean

Set OFSO = CreateObject("Scripting.FileSystemObject")
dirExists = OFSO.FolderExists(s_directory)

End Function

Ответ 3

If Len(Dir(ThisWorkbook.Path & "\YOUR_DIRECTORY", vbDirectory)) = 0 Then
   MkDir ThisWorkbook.Path & "\YOUR_DIRECTORY"
End If

Ответ 4

Чтобы убедиться, что существует папка (а не файл), я использую эту функцию:

Public Function FolderExists(strFolderPath As String) As Boolean
    On Error Resume Next
    FolderExists = ((GetAttr(strFolderPath) And vbDirectory) = vbDirectory)
    On Error GoTo 0
End Function

Он работает как с \ в конце, так и без.

Ответ 5

Вы можете заменить WB_parentfolder чем-то вроде "C: \". Для меня WB_parentfolder захватывает местоположение текущей книги. file_des_folder - это новая папка, которую я хочу. Это проходит и создает столько папок, сколько вам нужно.

        folder1 = Left(file_des_folder, InStr(Len(WB_parentfolder) + 1, file_loc, "\"))
        Do While folder1 <> file_des_folder
            folder1 = Left(file_des_folder, InStr(Len(folder1) + 1, file_loc, "\"))
            If Dir(file_des_folder, vbDirectory) = "" Then      'create folder if there is not one
                MkDir folder1
            End If
        Loop

Ответ 6

В итоге я использовал:

Function DirectoryExists(Directory As String) As Boolean
 DirectoryExists = False
 If Not Dir(Directory, vbDirectory) = "" Then
    If GetAttr(Directory) And vbDirectory = vbDirectory Then
        DirectoryExists = True
    End If
 End If
End Function

Какая смесь ответов @Brian и @ZygD. где я думаю, что ответ @Brian недостаточно и не нравится "On Error Resume Next" из ответа @ZygD