Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Создать папки и подпапки в директории файла по имени листов
 
#1
28.04.2014 12:08:50
Запутался как правильно прописать MkDir ThisWorkbook.Path

В общем нужно создать папку и подпапки  в тойже директории где лежит файл
при этом
1.Создать общую папку "Сотрудники"
в этой папке
2.Создать подпапки с именами сотрудников (по имени листов сотрудников) - причем листы сотрудников будут дополнятся потом листами новых сотрудников
3.Отдельная подпапка "Архив" рядом

Файл мой прилагаю - частично только папку Сотрудники сделал-подпапки не получается
Изменено: oleg4224 - 28.04.2014 12:16:33
 
 
 
#2
28.04.2014 12:33:45
Код
Sub Создать_папки()
    On Error Resume Next

    ' название папки,
    Const folder$ = "Сотрудники"

    ' создаём папку для файла, если её ещё нет
    MkDir ThisWorkbook.Path & "\" & folder$

    ' создаем подпапки для каждого листа
    For Each sh In ThisWorkbook.Worksheets
        MkDir ThisWorkbook.Path & "\" & folder$ & "\" & sh.Name
    Next sh

    ' создаём папку АРХИВ
    MkDir ThisWorkbook.Path & "\" & "Архив"

End Sub
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#3
28.04.2014 12:38:01
Пробуйте
Код
Declare Function MakeSureDirectoryPathExists Lib "Imagehlp.dll" (ByVal strPath As String) As Long
    'проверяет наличие папки с указанным путем и создает, если ее нет
    'возвращает 0, если папку создать не удалось и не-0, если ОК

Sub Создать_папки()
   Dim i&, fldr$
   fldr = ThisWorkbook.Path & "\" & "Сотрудники\"
    ' создаём папку для файла, если её ещё нет
   If MakeSureDirectoryPathExists(fldr) = 0 Then GoTo err
   If MakeSureDirectoryPathExists(fldr & "Архив\") = 0 Then GoTo err
   For i = 2 To Sheets.Count - 2
    If MakeSureDirectoryPathExists(fldr & Sheets(i).Name & "\") = 0 Then GoTo err
   Next
   Exit Sub
err: MsgBox "ошибка"
End Sub
 
 
 
#4
28.04.2014 12:56:55
Сделал так - исключил из создания папок листы не относящиеся к сотрудникам
Но при этом вылез другой косяк - папка Архив не создается - что не так сделал ?
Код
 Sub Создать_папки() 
    On Error Resume Next 
 
    ' название папки, 
    Const folder$ = "Сотрудники" 
 
    ' создаём папку для файла, если её ещё нет 
    MkDir ThisWorkbook.Path & "\" & folder$ 
     
    ' создаём папку АРХИВ 
    MkDir ThisWorkbook.Path & "\" & "Архив" 
 
    ' создаем подпапки для каждого листа 
    For Each sh In ThisWorkbook.Worksheets 
    If sh.Name <> "Расписание" And sh.Name <> "Норма" And sh.Name <> "Общий" Then 'выбираем только листы сотрудников- остальные исключаем 
       MkDir ThisWorkbook.Path & "\" & folder$ & "\" & sh.Name 
    End If 
    Next sh    
 End Sub
 
 
 
#5
28.04.2014 13:02:16
У меня папка создаётся.
There is no knowledge that is not power
 
 
 
#6
28.04.2014 13:27:35
мой косяк был - неправильно по заданию сделал - папка Архив вложена в папку Сотрудники рядом с папками сотрудников

Остался один вопрос - а почему в макросе уважаемого Казанский  VBA ругается на функцию
Declare Function MakeSureDirectoryPathExists Lib "Imagehlp.dll" (ByVal strPath As String) As Long
красным ?
у меня Office2010 x64 - может из-за этого ?
Код
Sub Создать_папки1() 
    On Error Resume Next 
 
    ' название папки, 
    Const folder$ = "Сотрудники" 
 
    ' создаём папку для файла, если её ещё нет 
    MkDir ThisWorkbook.Path & "\" & folder$ 
     
    ' создаём папку АРХИВ вложена в папку Сотрудники
    MkDir ThisWorkbook.Path & "\" & folder$ & "\" & "Архив" 
 
    ' создаем подпапки для каждого листа 
    For Each sh In ThisWorkbook.Worksheets 
    If sh.Name <> "Расписание" And sh.Name <> "Норма" And sh.Name <> "Общий" Then 'выбираем только листы сотрудников- остальные исключаем 
       MkDir ThisWorkbook.Path & "\" & folder$ & "\" & sh.Name 
    End If 
    Next sh  
End Sub  
Изменено: oleg4224 - 28.04.2014 17:35:51
 
 
 
#7
28.04.2014 13:31:01
Офис 64 битный?
Declare PtrSafe Function MakeSureDirectoryPathExists Lib "Imagehlp.dll" (ByVal strPath As String) As Long
Изменено: Johny - 28.04.2014 13:32:54
There is no knowledge that is not power
 
 
 
#8
28.04.2014 13:32:30
Office2010 x64
 
 
 
#9
28.04.2014 13:33:23
Declare PtrSafe Function MakeSureDirectoryPathExists Lib "Imagehlp.dll" (ByVal strPath As String) As Long
There is no knowledge that is not power
 
 
 
#10
28.04.2014 13:56:48
64-битный не может работать в 32. А значит скорее всего подойдет не As Long, а As LongLong
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#11
28.04.2014 14:51:24
Вообще, эту функцию правильнее было бы объявлять так:
Код
#If VBA7 Then        ' Office 2010-2013
     Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
            (ByVal hwnd As LongPtr, ByVal pszPath As String, ByVal psa As Any) As LongPtr

#Else        ' Office 2003-2007
    Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
                                         (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
#End If  
LongPtr вместо Long или LongLong  

Но, зачем ето вообще надо?
структура папок простейшая, - MkDir тут в самый раз
Надстройки для Excel  Парсинг сайтов  Мониторинг цен конкурентов
 
 
 
#12
28.04.2014 15:02:29
Цитата
Игорь пишет: Но, зачем ето вообще надо?
Затем, что
Цитата
oleg4224 пишет: причем листы сотрудников будут дополнятся потом листами новых сотрудников
Можно, конечно, проверять наличие папки, ловить ошибки...
 
 
 
#13
28.04.2014 15:11:23
Цитата
Игорь пишет:
Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As LongPtr, ByVal pszPath As String, ByVal psa As Any) As LongPtr
Ну и причём тут LongPtr? В документации сказано, что функция возвращает int.
There is no knowledge that is not power
 
 
 
#14
28.04.2014 15:36:10
There is no knowledge that is not power
 
 
 
Страницы: 1
Читают тему
Наверх