在 Excel VBA 中创建文件夹和子文件夹

Create a folder and sub folder in Excel VBA

提问by Matt Ridge

I have a pull down menu of companies that is populated by a list on another sheet. Three columns, Company, Job #, and Part Number.

我有一个公司的下拉菜单，该菜单由另一张纸上的列表填充。三列，公司、工作编号和零件编号。

When a job is created I need a folder for said company and a sub-folder for said Part Number.

创建工作时，我需要一个该公司的文件夹和一个该零件号的子文件夹。

If you go down the path it would look like:

如果你沿着这条路走下去，它看起来像：

C:\Images\Company Name\Part Number\

C:\图像\公司名称\零件编号\

If either company name or Part number exists don't create, or overwrite the old one. Just go to next step. So if both folders exist nothing happens, if one or both don't exist create as required.

如果公司名称或零件编号存在，请不要创建或覆盖旧的。只需进行下一步。因此，如果两个文件夹都存在，则不会发生任何事情，如果一个或两个文件夹都不存在，则根据需要创建。

Another question is there a way to make it so it works on Macs and PCs the same?

另一个问题是有没有办法让它在 Mac 和 PC 上都能正常工作？

采纳答案by Scott Holtzman

One sub and two functions. The sub builds your path and use the functions to check if the path exists and create if not. If the full path exists already, it will just pass on by. This will work on PC, but you will have to check what needs to be modified to work on Mac as well.

一分二功能。sub 构建您的路径并使用函数检查路径是否存在，如果不存在则创建。如果完整路径已经存在，它只会通过。这将在 PC 上运行，但您必须检查需要修改哪些内容才能在 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

回答by Martin

Another simple version working on PC:

另一个在 PC 上运行的简单版本：

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

回答by Leandro Jacques

I found a much better way of doing the same, less code, much more efficient. Note that the """" is to quote the path in case it contains blanks in a folder name. Command line mkdir creates any intermediary folder if necessary to make the whole path exist.

我找到了一种更好的方法来做同样的事情，代码更少，效率更高。请注意，"""" 用于引用路径，以防文件夹名称中包含空格。如果需要使整个路径存在，命令行 mkdir 会创建任何中间文件夹。

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

回答by Chandan Kumar

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

    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = Format(Now(), "dd-mm-yyyy")
    fldrpath = "C:\Temp\" & fldrname
    If Not fso.FolderExists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If
End Sub

回答by SandPiper

There are some good answers on here, so I will just add some process improvements. A better way of determining if the folder exists (does not use FileSystemObjects, which not all computers are allowed to use):

这里有一些很好的答案，所以我只会添加一些流程改进。确定文件夹是否存在的更好方法（不使用 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

Likewise,

同样地，

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

回答by Zoynels

Function MkDir(ByVal strDir As String)
    Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(strDir) Then
        ' create parent folder if not exist (recursive)
        MkDir (fso.GetParentFolderName(strDir))
        ' doesn't exist, so create the folder
        fso.CreateFolder strDir
    End If
End Function

回答by mindgutter

For those looking for a cross-platform way that works on both Windows and Mac, the following works:

对于那些正在寻找适用于 Windows 和 Mac 的跨平台方式的人，以下方法有效：

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

    strCheckPath = ""
    For Each elm In Split(strPath, Application.PathSeparator)
        strCheckPath = strCheckPath & elm & Application.PathSeparator
        If (Len(strCheckPath) > 1 And Not FolderExists(strCheckPath)) Then
            MkDir strCheckPath
        End If
    Next
End Sub

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

回答by Sascha L.

I know this has been answered and there were many good answers already, but for people who come here and look for a solution I could post what I have settled with eventually.

我知道这已经得到了回答，并且已经有很多很好的答案，但是对于来这里寻找解决方案的人，我可以发布我最终解决的问题。

The following code handles both paths to a drive (like "C:\Users...") and to a server address (style: "\Server\Path.."), it takes a path as an argument and automatically strips any file names from it (use "\" at the end if it's already a directory path) and it returns false if for whatever reason the folder could not be created. Oh yes, it also creates sub-sub-sub-directories, if this was requested.

下面的代码处理驱动器（如“C:\Users...”）和服务器地址（样式：“\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

I hope someone may find this useful. Enjoy! :-)

我希望有人会觉得这很有用。享受！:-)

回答by Rubber Toe

This is a recursive version that works with letter drives as well as UNC. I used the error catching to implement it but if anyone can do one without, I would be interested to see it. This approach works from the branches to the root so it will be somewhat usable when you don't have permissions in the root and lower parts of the directory tree.

这是一个递归版本，适用于字母驱动器和 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

回答by Patrick Honorez

Never tried with non Windows systems, but here's the one I have in my library, pretty easy to use. No special library reference required.

从未尝试过非 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