Создать папку и подпапку в Excel VBA

Ответ 1

Одна вспомогательная и две функции. Sub строит ваш путь и использует функции, чтобы проверить, существует ли путь и создать, если нет. Если полный путь уже существует, он просто пройдет. Это будет работать на ПК, но вам нужно будет проверить, что нужно изменить для работы на Mac.

'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()

Dim strComp As String, strPart As String, strPath As String

strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"

If Not FolderExists(strPath & strComp) Then 
'company doesn't exist, so create full path
    FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
    If Not FolderExists(strPath & strComp & "\" & strPart) Then
        FolderCreate strPath & strComp & "\" & strPart
    End If
End If

End Sub

Function FolderCreate(ByVal path As String) As Boolean

FolderCreate = True
Dim fso As New FileSystemObject

If Functions.FolderExists(path) Then
    Exit Function
Else
    On Error GoTo DeadInTheWater
    fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
    Exit Function
End If

DeadInTheWater:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    FolderCreate = False
    Exit Function

End Function

Function FolderExists(ByVal path As String) As Boolean

FolderExists = False
Dim fso As New FileSystemObject

If fso.FolderExists(path) Then FolderExists = True

End Function

Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters

    CleanName = Replace(strName, "/","")
    CleanName = Replace(CleanName, "*","")
    etc...

End Function

Ответ 2

Еще одна простая версия, работающая на ПК:

Sub CreateDir(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, "\")
        strCheckPath = strCheckPath & elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub

Ответ 3

Я нашел гораздо лучший способ сделать то же самое, меньше кода, гораздо более эффективным. Обратите внимание, что "" " - это указать путь в случае, если он содержит пробелы в имени папки. Командная строка mkdir создает любую промежуточную папку, если необходимо, чтобы весь путь существовал.

If Dir(YourPath, vbDirectory) = "" Then
    Shell ("cmd /c mkdir """ & YourPath & """")
End If

Ответ 4

Private Sub CommandButton1_Click()
    Dim fso As Object
    Dim tdate As Date
    Dim fldrname As String
    Dim fldrpath As String

    tdate = Now()
    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = Format(tdate, "dd-mm-yyyy")
    fldrpath = "C:\Users\username\Desktop\FSO\" & fldrname
    If Not fso.folderexists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If
End Sub

Ответ 5

Здесь есть несколько хороших ответов, поэтому я просто добавлю некоторые улучшения в процессе. Лучший способ определить, существует ли папка (не использует FileSystemObjects, которую не все компьютеры могут использовать):

Function FolderExists(FolderPath As String) As Boolean
     FolderExists = True
     On Error Resume Next
     ChDir FolderPath
     If Err <> 0 Then FolderExists = False
     On Error GoTo 0
End Function

Аналогично,

Function FileExists(FileName As String) As Boolean
     If Dir(FileName) <> "" Then FileExists = True Else FileExists = False
EndFunction

Ответ 6

Это работает как прелесть в AutoCad VBA, и я схватил его с форума excel. Я не знаю, почему вы все так усложняете?

ЧАСТО ЗАДАВАЕМЫЕ ВОПРОСЫ

Вопрос: Я не уверен, существует ли определенная директория. Если он не существует, я хотел бы создать его с помощью кода VBA. Как я могу это сделать?

Ответ. Вы можете проверить, существует ли каталог с помощью кода VBA ниже:

(Котировки ниже опущены, чтобы избежать путаницы кода программирования)

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then

   MkDir "c:\TOTN\Excel\Examples"

End If

http://www.techonthenet.com/excel/formulas/mkdir.php

Ответ 7

Здесь короткий sub без обработки ошибок, который создает подкаталоги:

Public Function CreateSubDirs(ByVal vstrPath As String)
   Dim marrPath() As String
   Dim mint As Integer

   marrPath = Split(vstrPath, "\")
   vstrPath = marrPath(0) & "\"

   For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
      If (Dir(vstrPath, vbDirectory) = "") Then Exit For
      vstrPath = vstrPath & marrPath(mint) & "\"
   Next mint

   MkDir vstrPath

   For mint = mint To UBound(marrPath) 'create directories
      vstrPath = vstrPath & marrPath(mint) & "\"
      MkDir vstrPath
   Next mint
End Function

Ответ 8

Никогда не пробовал с не Windows системами, но вот тот, который у меня есть в моей библиотеке, довольно прост в использовании. Никакой специальной библиотеки не требуется.

Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'create full sPath at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")

    Dim fs As Object 
    Dim FolderArray
    Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC path ? change 3 "\" into 3 "@"
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    'now split
    FolderArray = Split(sPath, "\")
    'then set back the @ into \ in item 0 of array
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo hell
    'start from root to end, creating what needs to be
    For i = 0 To UBound(FolderArray) Step 1
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    CreateFolder = True
hell:
End Function

Ответ 9

Я знаю, что на это был дан ответ, и уже было много хороших ответов, но для людей, которые приходят сюда и ищут решение, я мог бы опубликовать то, что я решил со временем.

Следующий код обрабатывает оба пути к диску (например, "C:\Users..." ) и к адресу сервера (style: "\ Server\Path.." ), он принимает путь в качестве аргумента и автоматически удаляет из него любые имена файлов (используйте "\" в конце, если это уже путь к каталогу) и возвращает false, если по какой-то причине невозможно создать папку. О да, он также создает суб-под-подкаталоги, если это было запрошено.

Public Function CreatePathTo(path As String) As Boolean

Dim sect() As String    ' path sections
Dim reserve As Integer  ' number of path sections that should be left untouched
Dim cPath As String     ' temp path
Dim pos As Integer      ' position in path
Dim lastDir As Integer  ' the last valid path length
Dim i As Integer        ' loop var

' unless it all works fine, assume it didn't work:
CreatePathTo = False

' trim any file name and the trailing path separator at the end:
path = Left(path, InStrRev(path, Application.PathSeparator) - 1)

' split the path into directory names
sect = Split(path, "\")

' what kind of path is it?
If (UBound(sect) < 2) Then ' illegal path
    Exit Function
ElseIf (InStr(sect(0), ":") = 2) Then
    reserve = 0 ' only drive name is reserved
ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then
    reserve = 2 ' server-path - reserve "\\Server\"
Else ' unknown type
    Exit Function
End If

' check backwards from where the path is missing:
lastDir = -1
For pos = UBound(sect) To reserve Step -1

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' check if this path exists:
    If (Dir(cPath, vbDirectory) <> vbNullString) Then
        lastDir = pos
        Exit For
    End If

Next ' pos

' create subdirectories from that point onwards:
On Error GoTo Error01
For pos = lastDir + 1 To UBound(sect)

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' create the directory:
    MkDir cPath

Next ' pos

CreatePathTo = True
Exit Function

Error01:

End Function

Надеюсь, кто-то найдет это полезным. Наслаждайтесь!: -)

Ответ 10

Это рекурсивная версия, которая работает как с буквенными дисками, так и с UNC. Я использовал перехват ошибок для реализации, но если кто-то может сделать это без, мне было бы интересно увидеть это. Этот подход работает от ветвей до корня, поэтому он будет несколько полезен, если у вас нет разрешений в корневой и нижней частях дерева каталогов.

' Reverse create directory path. This will create the directory tree from the top    down to the root.
' Useful when working on network drives where you may not have access to the directories close to the root
Sub RevCreateDir(strCheckPath As String)
    On Error GoTo goUpOneDir:
    If Len(Dir(strCheckPath, vbDirectory)) = 0 And Len(strCheckPath) > 2 Then
        MkDir strCheckPath
    End If
    Exit Sub
' Only go up the tree if error code Path not found (76).
goUpOneDir:
    If Err.Number = 76 Then
        Call RevCreateDir(Left(strCheckPath, InStrRev(strCheckPath, "\") - 1))
        Call RevCreateDir(strCheckPath)
    End If
End Sub

Ответ 11

        Sub MakeAllPath(ByVal PS$)
Dim PP$
If PS <> "" Then
    ' chop any end  name
    PP = Left(PS, InStrRev(PS, "\") - 1)
    ' if not there so build it
    If Dir(PP, vbDirectory) = "" Then
        MakeAllPath Left(PP, InStrRev(PS, "\") - 1)
        ' if not back to drive then  build on what is there
        If Right(PP, 1) <> ":" Then MkDir PP
    End If
End If

End Sub

Версия цикла Martins выше, чем моя рекурсивная версия так улучшить до

Sub MakeAllDir (PathS $)

'формат "K:\firstfold\secf\fold3"

Если Dir (PathS) = vbNullString, то

иначе не беспокойтесь

Dim LI & amp;, MYPath $, BuildPath $, PathStrArray $()

PathStrArray = Split (PathS, "\")

  BuildPath = PathStrArray(0) & "\"    '

  If Dir(BuildPath) = vbNullString Then 

'проблема с ловушкой без диска:\указан путь

     If vbYes = MsgBox(PathStrArray(0) & "< not there for >" & PathS & " try to append to " & CurDir, vbYesNo) Then
        BuildPath = CurDir & "\"
     Else
        Exit Sub
     End If
  End If
  '
  ' loop through required folders
  '
  For LI = 1 To UBound(PathStrArray)
     BuildPath = BuildPath & PathStrArray(LI) & "\"
     If Dir(BuildPath, vbDirectory) = vbNullString Then MkDir BuildPath
  Next LI

Конец, если

был уже там

End Sub

использовать как 'MakeAllDir "K:\bil\joan\Johno"

'MakeAllDir "K:\bil\joan\Fredso"

'MakeAllDir "K:\bil\tom\wattom"

'MakeAllDir "K:\bil\herb\watherb"

'MakeAllDir "K:\bil\herb\Jim"

Диск по умолчанию 'MakeAllDir "bil\joan\wat"