Создание папок с подпапками макросом VBA

Как известно, VBA-функция MkDir может создать только папку в существующем каталоге (папке).
 
Например, код MkDir "C:\Папка\" отработает корректно в любом случае (создаст указанную папку),
а код MkDir "C:\Папка\Подпапка\Каталог\" выдаст ошибку Run-time error '76': Path not found
(потому что невозможно создать каталог Подпапка в несуществующем ещё каталоге Папка)
 
Можно, конечно, использовать несколько функций MkDir подряд - но это усложняет код.
 
Самый простой способ решения проблемы - использование WinAPI-функции SHCreateDirectoryEx, которая может создать все нужные папки и подпапки за один запуск.

Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
                                     (ByVal hwnd As Long, ByVal pszPath As String, _
                                      ByVal psa As Any) As Long
 
 
Sub CreateFolderWithSubfolders(ByVal ПутьСоздаваемойПапки$)
    ' функция получает в качестве параметра путь к папке
    ' если такой папки ещё нет - она создаётся
    ' может создаваться сразу несколько подпапок
    If Len(Dir(ПутьСоздаваемойПапки$, vbDirectory)) = 0 Then    ' если папка отсутствует
        SHCreateDirectoryEx Application.hwnd, ПутьСоздаваемойПапки$, ByVal 0&    ' создаём путь
    End If
End Sub

Пример использования функции SHCreateDirectoryEx:

Sub ПримерИспользованияCreateFolderWithSubfolders()
    ' этот макрос создаст на диске C папку "Создаваемая папка",
    ' в ней - подпапку "Подпапка", а в последней - подпапку 1234
    Путь = "C:\Создаваемая папка\Подпапка\1234\"
 
    CreateFolderWithSubfolders Путь
End Sub

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Там всё намного сложнее. Зависит от того, через что осуществляется доступ к сайту.

А как при помощи VBA создать папку в облаке?
если расположение имеет следующий формат: "https://domen.com/Документы/"

Ну, например нужно создать 20 папок и еще подпапки. Сделать это за 1 клик или несколько, думаю разница очевидна-экономия времени

А какая разница, сразу или по очереди?
В любом случае это выполнится почти моментально.

А если нужно создать сразу несколько папок и подпапки в указанной директории по списку в эксель, это реализуемо?

Работает. Отлично работает.
На вопрос по Declare есть ответ пятью комментариями ниже

Не работает. Вообще.
B на вопрос о Declare полтора года нет ответа ... печально что-то

а что делать если на такую строку кода:

Declare function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

система реагирует ошибкой : Sub or function not defined?

Красиво, но в макросах Outlook не завелось.
Написал через FileSystemObject

Dim FSO
Dim saveFolder As String
 
Set FSO = CreateObject("Scripting.FileSystemObject")
saveFolder = "C:\Temp\"
 
If Not FSO.FolderExists(saveFolder) Then
    FSO.CreateFolder(saveFolder)
End If

Вася молодец! набросал себе процедуру для создания подкаталогов. Лишний раз API дёргать не буду.

Тот же макрос, только надо первую строку написать так:

Declare PrtSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
                                     (ByVal hwnd As LongPtr, ByVal pszPath As String, _
                                      ByVal psa As Any) As LongPtr

Здравствуйте, а для 64-битного офиса есть такие фишки?

Скажите пожалуйста , а как ещо добавить гиперлинк на созданую папку

Большое спасибо, очень помогли.

вариант без всяких лишних Declare:

Sub mkdir2(Путь$)
Set FSO = CreateObject("Scripting.FileSystemObject")
a = Split(Путь, "\")
For i = 0 To UBound(a)
If a(i) <> "" Then
aa = aa & a(i) & "\"
If FSO.FolderExists(aa) = False Then MkDir aa
End If
Next
End Sub

Спасибо Вам, попробую.

Здравствуйте, Иван.
Это не вопрос, это задание. Вопроса не вижу.

Вам на форуме не ответили по той же причине, - нет никакой конкретики (что именно у вас не получается)

Вот готовый код, - его надо только вставить в ваш файл, и запустить Макрос_который_нужно_запускать:

Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
                                     (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
 
 
Sub Макрос_который_нужно_запускать()
    Dim ra As Range, cell As Range, newPath$
 
    ' получаем диапазон заполненных ячеек в столбце А
    Set ra = Range(Range("a1"), Range("a" & Rows.Count).End(xlUp))
 
    ' для каждой ячейки создаем папки
    For Each cell In ra.Cells
        ' формируем путь
        newPath$ = "D:\" & cell.Value
 
        ' создаем папки с подпапками
        SHCreateDirectoryEx Application.hwnd, newPath$, ByVal 0&
    Next cell
End Sub

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

Доброго времени суток. У меня такой ворос. на диске D необходимо создавать папки из столбца А
(А1= папка1\подпапка2\
А2= папка2\подпапка 3\подпапка 4
и т.д.)

Друзья!
Такая ситуация:
Необходим создавать на диске D:\ папки и подпапки по значению ячеек двух соседних столбцов:
НАПРИМЕР:
D:\папка\подпапка\
если "папка"=А1....100000, а "подпапка"=В1....100000

спасибо, помогли!

Отлично работает

Где найти SHCreateDirectoryEx?

Добавил код функции SHCreateDirectoryEx в текст статьи.

Где найти SHCreateDirectoryEx? При попытке выполнения указывает "sub or function not defined"

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _____             _      __  __   _____       
|__ / __ _ / \ | \/ | | ___| ____
/ / / _` | / _ \ | |\/| | | |_ |_ /
/ /_ | (_| | / ___ \ | | | | | _| / /
/____| \__, | /_/ \_\ |_| |_| |_| /___|
|___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

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