Создание папок с подпапками макросом 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

73361 просмотр

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

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

Гость 2807, 29 Июл 2021 - 08:28.#1

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

Игорь (администратор сайта), 29 Июл 2021 - 00:06.#2

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

Гость 2807, 28 Июл 2021 - 16:07.#3

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

Игорь (администратор сайта), 23 Янв 2021 - 13:43.#4

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

Гость, 23 Янв 2021 - 07:35.#5

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

kwadrad, 31 Июл 2019 - 19:07.#6

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

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?

Konstantin, 28 Июн 2019 - 20:19.#7

Красиво, но в макросах 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

Олег, 27 Мар 2019 - 16:57.#8

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

Игорь (администратор сайта), 1 Июн 2017 - 20:42.#9

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

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

Владимир, 1 Июн 2017 - 17:45.#10

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

Владимир, 27 Фев 2017 - 17:52.#11

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

Алексей, 17 Дек 2015 - 19:18.#12

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

вася, 14 Дек 2014 - 19:59.#13

вариант без всяких лишних 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

Иван, 6 Май 2014 - 12:26.#14

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

Игорь (администратор сайта), 6 Май 2014 - 09:55.#15

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

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

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

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

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

Иван, 6 Май 2014 - 08:41.#16

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

Сергей, 4 Дек 2013 - 21:46.#17

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

Unique, 18 Апр 2011 - 12:55.#18

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

Гость, 19 Фев 2011 - 16:39.#19

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

Игорь (администратор сайта), 19 Фев 2011 - 03:48.#20

Где найти SHCreateDirectoryEx?

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

Гость, 18 Фев 2011 - 19:47.#21

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

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

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

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

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

Комментарии

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

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

НАДСТРОЙКИ ДЛЯ EXCEL