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

75474 просмотра

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

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

Игорь (администратор сайта), 2 Май 2024 - 01:00.#1

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

gatto, 30 Апр 2024 - 20:12.#2

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

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

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

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

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

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

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

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

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

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

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

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

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

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.#9

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

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

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

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

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.#12

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

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

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

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

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

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

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

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

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

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

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

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

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.#18

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

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

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

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

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

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

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

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

Где найти SHCreateDirectoryEx?

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

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

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

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

Ваше имя:

E-mail:

Содержание этого поля является приватным и не предназначено к показу.

Комментарий: *

Уведомлять меня о новых комментариях

CAPTCHA

Подтвердите, пожалуйста, что вы - человек:

  _____  __     __  ____   __  __              ____  
 |_   _| \ \   / / / ___|  \ \/ /  _ __ ___   |  _ \ 
   | |    \ \ / /  \___ \   \  /  | '_ ` _ \  | |_) |
   | |     \ V /    ___) |  /  \  | | | | | | |  __/ 
   |_|      \_/    |____/  /_/\_\ |_| |_| |_| |_|

Введите код, указанный выше: *

Введите код, изображенный в стиле ASCII-арт.

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

Комментарии

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

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

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