Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Макрос по созданию папки с именем ячейки
 
#1
05.09.2017 12:50:53
Коллеги, Добрый день! Помогите решить задачку. Из столбца G или H взять название строки, и создать папку с таким же именем например на рабочем столе . Папки  нужны для каждой строки.  
 
 
 
#2
05.09.2017 12:53:34
tairov-vladimir, посмотрите тут.
Upd. Простите, не внимательно прочитал пост, там немного другое :)
Вот код, создающий папки в директории где лежит файл:
Код
Sub createFolders()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FilesystemObject")
    For Each el In Range([G2], [G1].Offset([A2].End(xlDown).Row - 1, 0))
        If Not fso.FolderExists(ThisWorkbook.Path & "\" & el.Value) Then
            fso.CreateFolder (ThisWorkbook.Path & "\" & el.Value)
        End If
    Next
End Sub

Модификация для создания папок на рабочем столе:
Код
Sub createFoldersonDesktop()
    Dim fso As Object
    Set fso = CreateObject("Scripting.FilesystemObject")
    For Each el In Range([G2], [G1].Offset([A2].End(xlDown).Row - 1, 0))
        If Not fso.FolderExists(Environ("USERPROFILE") & "\Desktop\" & el.Value) Then
            fso.CreateFolder (Environ("USERPROFILE") & "\Desktop\" & el.Value)
        End If
    Next
End Sub
Изменено: tolstak - 05.09.2017 13:08:38
In GoTo we trust
 
 
 
#3
05.09.2017 13:33:52
Скажите а есть возможность создавать папки по указанному пути??
 
 
 
#4
05.09.2017 13:39:35
Код
    sFldr = Path  ' путь к папке
    If Dir(sFldr, vbDirectory) = "" Then MkDir sFldr ' создаем, если нет
 
 
 
#5
05.09.2017 13:47:51
vikttur, то есть в коде от tolstak меняем первые две строки?
 
 
 
#6
05.09.2017 13:49:56
Код
Sub createFolders()
    Dim fso As Object
    sFldr = "C:\ВашаПапка\"  ' путь к папке
    If Dir(sFldr, vbDirectory) = "" Then MkDir sFldr ' создаем, если нет
    Set fso = CreateObject("Scripting.FilesystemObject")
    For Each el In Range([G2], [G1].Offset([A2].End(xlDown).Row - 1, 0))
        If Not fso.FolderExists(sFldr  & el.Value) Then
            fso.CreateFolder (sFldr  & el.Value)
        End If
    Next
End Sub
Изменено: tolstak - 05.09.2017 13:50:04
In GoTo we trust
 
 
 
#7
05.09.2017 14:10:16
tolstak, получается но не то что хотелось бы, видимо не правильно изложил суть. как сделать так чтобы папка создавалась конкретно для одной выбранной ячейки, но  такая возможность была у каждой ячейки.
 
 
 
#8
05.09.2017 14:43:13
tairov-vladimir,
Код
Sub createFolders()
    Dim fso As Object, el As Range
    ' Выбор ячейки с названием папки
    Set el = Application.InputBox( _
        Prompt:="Выберите строку с названием папки", _
        Title:="Строка с названием", _
        Default:=Intersect([G:G], Selection.EntireRow).Address, _
        Type:=8)
    
    ' Папка для создания по умолчанию
    sFldr = "C:\Users\user\Desktop\ЕРЕМИАС\Новая папка\"
    ' Возмоожность изменить папку
    sFldr = InputBox( _
        Prompt:="Адрес сохранения", _
        Title:="Куда сохранять?", _
        Default:=sFldr)
    If Not el Is Nothing And sFldr <> "" And el.Value <> "" Then
        Set el = Intersect([G:G], el)
        If Dir(sFldr, vbDirectory) = "" Then MkDir sFldr ' создаем, если нет
        Set fso = CreateObject("Scripting.FilesystemObject")
        If Not fso.FolderExists(sFldr & el.Value) Then
            fso.CreateFolder (sFldr & el.Value)
        End If
    Else
        MsgBox "Папка или название файла не выбраны.", vbCritical
    End If
End Sub
In GoTo we trust
 
 
 
#9
04.10.2017 13:58:19
Здравствуйте.
При выполнении макроса из сообщения #8 возникает ошибка : Run-time error 76 Path not found
Debug показывает что ошибка в строке 19.
Подскажите, как исправить, пожалуйста.
 
 
 
#10
04.10.2017 14:01:55
Имеется в виду путь из строки 11?
 
 
 
#11
04.10.2017 14:02:34
Path not found - нет такого пути.
Строка 19 - создаем папку, если по указанному пути нет папки с таким именем.
sFldr - недопустимый путь. Проверьте переменную.
 
 
 
#12
04.10.2017 14:05:19
DmitriyBastr, вероятно, у Вас не создана корневая папка. В сообщении #8 папка по пути "C:\Users\user\Desktop\ЕРЕМИАС\Новая папка\Ц-108-30.08.3018-М-4" будет создана, если существует папка "C:\Users\user\Desktop\ЕРЕМИАС\Новая папка\".
Цитата
Имеется в виду путь из строки 11?
Да, или путь, указанный в всплывающем диалоге "Куда сохранять"
Изменено: tolstak - 04.10.2017 14:12:52
In GoTo we trust
 
 
 
#13
04.10.2017 14:13:47
Прописал в коде свой путь "C:\Users\user\Desktop\2"
Теперь выдает ошибку в строке 21
Object variable or With block variable not set
 
 
 
#14
04.10.2017 14:15:39
DmitriyBastr, пропишите с последним символом - слешем - "C:\Users\user\Desktop\2\", должно помочь.
In GoTo we trust
 
 
 
#15
04.10.2017 14:41:34
"\" есть, я его в сообщении просто не написал...
 
 
 
#16
04.10.2017 14:43:07
Ну, диск С у Вас, надеюсь, есть? :)
Проверьте так:
Код
sFldr = "C:\Новая папка\"
 
 
 
#17
04.10.2017 14:45:01
Цитата
DmitriyBastr написал:
"\" есть, я его в сообщении просто не написал
Почему не писали? Чтобы проверить, заметят ли форумчане эту ошибку?
 
 
 
#18
04.10.2017 15:01:50
Всё... Разобрался... Заработало
Большое спасибо!!!
 
 
 
#19
04.10.2017 15:48:59
... Все-таки продолжу...
Код из сообщения #8 работает. Но он создает папку только с именем из 7-го столбца, а не из любой выбранной ячейки, как было написано в сообщении #7. Что с этим можно сделать?
 
 
 
#20
04.10.2017 15:52:53
DmitriyBastr, уберите из кода эту строку:
Код
Set el = Intersect([G:G], el)
In GoTo we trust
 
 
 
#21
04.10.2017 16:10:58
Ни как не повлияло...
 
 
 
#22
22.05.2019 11:43:28
tolstak, Добрый день! при запуске этого макроса, Excel зависает минут на 5, это нормально? Помогите пожалуйста
Код
Sub createFolders()
    Dim fso As Object
    sFldr = "C:\ВашаПапка\"  ' путь к папке
    If Dir(sFldr, vbDirectory) = "" Then MkDir sFldr ' создаем, если нет
    Set fso = CreateObject("Scripting.FilesystemObject")
    For Each el In Range([G2], [G1].Offset([A2].End(xlDown).Row - 1, 0))
        If Not fso.FolderExists(sFldr  & el.Value) Then
            fso.CreateFolder (sFldr  & el.Value)
        End If
    Next
End Sub
 
 
 
#23
22.05.2019 12:25:10
Для начала проверьте букву "С" в ячейке А1
 
 
 
#24
23.05.2019 06:27:57
Юрий М, спасибо исправил, но макрос все равно зависает на минут 5
 
 
 
#25
23.05.2019 11:50:05
Так у Вас в примере цикл перебирает все ячейки столбца, а это 1 048 576 строк.
 
 
 
#26
27.05.2020 16:20:17
Добрый день.

Кто может помочь на форуме нашел, что кто-то уже организовывал создание подпапок но только до 2-го уровня. Так как я не владею VBА на должном уровне помогите пожалуйста чтобы создавались папки до 4 уровня. Я привел примеры.  
 
 
 
#27
10.08.2022 17:21:05
Здравствуйте, не хотелось плодить дополнительных тем, поэтому  пишу здесь:
По примеру решений на форуме, захотел сделать макрос, который создает папку исходя из данных из строк в exel.

при  этом важная задача:  привязывать создаваемые папки к региону .  а не сохранять в рандомных местах.
но выкидывает ошибку.
похоже на ошибку пунктуации.

Наименование создаваемой папки формируется из столбца 3,2 , 4 и 5.  

изначально хотел добавить, чтобы формировалась главная папка с привязкой к году. но от этой идеи отказался.  
 
 
 
#28
14.07.2023 17:36:53
Добрый день. Нужна ваша помощь в создании макроса, так как сам в VBA не силен.

1. Требуется создать папку с именем из ячейки А18
2. Требуется поместить созданную папку используя путь указанный в ячейке  B16 (переменная)
3. требуется копировать папку с подпапками и файлами, путь указан в ячейке С13 в созданную ранее папку

изучив имеющиеся материалы воспользовался макросом предложенным ранее #8 05.09.2017 14:43:13.
Доработав его удалось решить 1. задачу, создать папку с именем указанным в ячейке А18, но возникла проблема, которую не удается решить самостоятельно.
Путь по которому располагается созданная папка "константа", не удается его привязать к ячейке В16 (переменной), подскажите как это реализовать.

А также подскажите возможно ли вписать макрос копирования папок в данный макрос, для решения всех поставленных задач одним действием ?
Код
Sub createFolders()
    Dim fso As Object, el As Range
    ' Выбор ячейки с названием папки
    Set el = Application.InputBox( _
        Prompt:="Выберите строку с названием папки", _
        Title:="Строка с названием", _
        Default:=Intersect([A18], Selection.EntireRow).Address, _
        Type:=8)
    
    ' Папка для создания по умолчанию
    sFldr = "C:\Users\USER\Desktop\СК ТАНДЕР\Отчеты\"
    ' Возмоожность изменить папку
    sFldr = InputBox( _
        Prompt:="Адрес сохранения", _
        Title:="Куда сохранять?", _
        Default:=sFldr)
    If Not el Is Nothing And sFldr <> "" And el.Value <> "" Then
        Set el = Intersect([A1:B18], el)
        If Dir(sFldr, vbDirectory) = "" Then MkDir sFldr ' создаем, если нет
        Set fso = CreateObject("Scripting.FilesystemObject")
        If Not fso.FolderExists(sFldr & el.Value) Then
            fso.CreateFolder (sFldr & el.Value)
        End If
    Else
        MsgBox "Папка или название файла не выбраны.", vbCritical
    End If
End Sub
 
 
 
#29
14.07.2023 17:55:33
МВВ МВВ, добрый день! Можно например так:
Код
Sub create_and_copy()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FilesystemObject")
FSO.createfolder ([B2].Value & Application.PathSeparator & [B1].Value)
FSO.copyFolder [B2].Value, [B3].Value
End Sub
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/copyfolder-metho...
Для примера приложил файл с комментариями
 
 
 
#30
14.07.2023 17:56:27
МВВ МВВ, чёт сложно, не понял...
Давайте лучше вот это (такой пример есть) под виндой на API использовать:
Код
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub bb()
    Const ROOT = "d:\"
    Dim c
    For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp)).Cells
         MakeSureDirectoryPathExists ROOT & c & "\"
    Next
End Sub

Надеюсь переделаете под свои ячейки (или пару ячеек).
Но нужно ещё учесть что не все символы которые могут быть в ячейках допустимы как имена каталогов/файлов (есть тут на форуме функции по замене таких символов)..
И ещё - если в путях есть диакритика, то нужно другую функцию использовать, там чуть сложнее поэтому тут не привожу.
Изменено: Hugo - 14.07.2023 17:58:25
 
 
 
Страницы: 1 2 След.
Наверх