Excel VBA создает папку, подпапки и другие подпапки

Question

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

В Excel у меня есть файл, который используется для профиля именования папок цитат.

Я попытался использовать ответ для: Создание папки и подпапки в Excel VBA и настроил его в соответствии с нижеприведенным описанием, но при достижении * 1007 выдает ошибку

Ошибка времени выполнения '424': требуется объект.

Мне также нужно создать имя папки в соответствии с ячейкой «Ввод данных» «C44» и «C31», затем мне нужно добавить к ней подпапки, на которые нет ссылок ни в одной ячейке, включая: 1. Запрос клиента Это будет иметь дополнительную подпапку с именем базы в ячейке «Ввод данных» «C33»

Проектирование Чертежи Калькуляции Расписания Цитата

Любая помощь будет принята с благодарностью. Спасибо,

'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()

Dim strFolder As String, strPath As String

strFolder = CleanName(Range("C31")) ' assumes folder name is in C31
strPath = Range("C44") ' assumes path name is in C44

If Not FolderExists(strPath) Then
'Path doesn't exist, so create full path
    FolderCreate strPath & "\" & strFolder
Else
'Path does exist, but no quote folder
    If Not FolderExists(strPath & "\" & strFolder) Then
        FolderCreate strPath & "\" & strFolder
    End If
End If

End Sub

Function FolderCreate(ByVal path As String) As Boolean

FolderCreate = True
Dim fso As New FileSystemObject

If Functions.FolderExists(path) Then 'This is the part that doesn't work
    Exit Function
Else
    On Error GoTo DeadInTheWater
    fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
    Exit Function
End If

DeadInTheWater:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    FolderCreate = False
    Exit Function

End Function

Function FolderExists(ByVal path As String) As Boolean

FolderExists = False
Dim fso As New FileSystemObject

If fso.FolderExists(path) Then FolderExists = True

End Function

Function CleanName(strName As String) As String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters

    CleanName = Replace(strName, "/", "")
    CleanName = Replace(CleanName, "*", "")

End Function

Любая помощь с благодарностью. Спасибо

Answer 1

спасибо @BigBen, @BrianMStafford за вашу помощь. Мне удалось придумать, что работает. Это создаст 10 подпапок в главной папке, которая находится в указанном ячейке. Затем он создает дополнительную подпапку в папке 1.

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

После этого, когда я решу, как это сделать, я планирую заставить его открыть папку, которую пользователь будет использовать первым. В моем случае это последняя созданная папка. Надеюсь, это кому-нибудь поможет: -)

'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()

Dim strFolder As String, strPath As String

strFolder = CleanName(Range("C31")) ' assumes folder name is in C31
strPath = Range("C44") ' assumes path name is in C44

If Not FolderExists(strPath) Then
'Path doesn't exist, so create full path
    FolderCreate strPath & "\" & strFolder
Else
'Path does exist, but no quote folder
    If Not FolderExists(strPath & "\" & strFolder) Then
        FolderCreate strPath & "\" & strFolder
        FolderCreate strPath & "\" & strFolder & "\" & "01. Customer RFQ"
        FolderCreate strPath & "\" & strFolder & "\" & "02. Design Engineering"
        FolderCreate strPath & "\" & strFolder & "\" & "03. Drawings"
        FolderCreate strPath & "\" & strFolder & "\" & "04. Costings"
        FolderCreate strPath & "\" & strFolder & "\" & "05. Schedules"
        FolderCreate strPath & "\" & strFolder & "\" & "06. Quotation"
        FolderCreate strPath & "\" & strFolder & "\" & "07. Email"
        FolderCreate strPath & "\" & strFolder & "\" & "08. MOMs"
        FolderCreate strPath & "\" & strFolder & "\" & "09. Sales Excellence"
        FolderCreate strPath & "\" & strFolder & "\" & "10. Compliance"
        FolderCreate strPath & "\" & strFolder & "\" & "01. Customer RFQ" & "\" & Range("C33")
    End If
End If

End Sub

Function FolderCreate(ByVal path As String) As Boolean

FolderCreate = True
Dim fso As New FileSystemObject

If fso.FolderExists(path) Then
    Exit Function
Else
    On Error GoTo DeadInTheWater
    fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
    Exit Function
End If

DeadInTheWater:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    FolderCreate = False
    Exit Function

End Function

Function FolderExists(ByVal path As String) As Boolean

FolderExists = False
Dim fso As New FileSystemObject

If fso.FolderExists(path) Then FolderExists = True

End Function

Function CleanName(strName As String) As String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters

    CleanName = Replace(strName, "/", "")
    CleanName = Replace(CleanName, "*", "")

End Function