在ExcelVBA中创建文件夹和子文件夹

Question

>我有一个公司的下拉菜单，由另一张纸上的列表填充。三列：公司、作业 # 和部件号。

创建作业时，我需要该公司的文件夹和所述零件号的子文件夹。

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

C：\图片\公司名称\部件号\

如果存在公司名称或部件号

，请不要创建或覆盖旧名称或部件号。只需转到下一步。因此，如果两个文件夹都存在，则不会发生任何反应，如果一个或两个都不存在，请根据需要创建。

另一个问题是有没有办法让它在 Mac 和 PC 上同样工作？

Answer 1

另一个在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

Answer 2

一个子函数和两个函数。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

Answer 3

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

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

Answer 4

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

Answer 5

这里有一些很好的答案，所以我只会添加一些流程改进。确定文件夹是否存在的更好方法（不使用文件系统对象，并非所有计算机都允许使用）：

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

Answer 6

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

Answer 7

这就像AutoCad VBA中的一个魅力，我从excel论坛中抓取了它。我不知道你们为什么都把它弄得这么复杂？

常见问题

问：我不确定特定目录是否已经存在。如果它不存在，我想使用 VBA 代码创建它。我该怎么做？

答：您可以使用下面的VBA代码测试目录是否存在：

（以下引号省略，以免混淆编程代码）

<小时 />

If Len(Dir("c:TOTNExcelExamples", vbDirectory)) = 0 Then
   MkDir "c:TOTNExcelExamples"
End If

<小时 />

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

Answer 8

对于那些寻找一种同时适用于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

Answer 9

从未尝试过使用非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:tototesttest") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\MyServerMyShareMyFolder")
    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

Answer 10

下面是没有错误处理的短子，用于创建子目录：

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

Answer 11

我知道

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

以下代码处理驱动器（如"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

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

Answer 12

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

Answer 13

Sub FolderCreate()
    MkDir "C:Test"
End Sub

Answer 14

所有其他答案都是不必要的组合！您可以使用 2 行代码递归创建所有文件夹树，请检查以下内容：

Public Sub MkDir_recursive(ByVal folder As String)
    'Dim fso As Object : Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fso As New FileSystemObject 'If this throws an error, use above declaration instead
    ' Create parent folder if necessary (recursive)
    If Not fso.FolderExists(fso.GetParentFolderName(folder)) Then MkDir_recursive fso.GetParentFolderName(folder)
    If Not fso.FolderExists(folder) Then fso.CreateFolder folder 'All subfolders exist when we get here.
End Sub

sub 检查父文件夹

是否存在，在这种情况下，它调用具有父文件夹的同一 sub，父文件夹在 on 和 on 上执行相同的操作。这一直持续到文件夹存在或到达根文件夹（将始终存在）为止。什么时候

注意：也适用于UNC文件夹（如\\服务器\我的共享\文件夹）

<小时 />

我无法访问任何MAC，但是您可以使用相同的概念，这非常简单。

Answer 15

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 loop version above is better than MY recursive version
'so improve to below
Sub MakeAllDir(PathS$)            
  ' format "K:firstfoldsecffold3"
  If Dir(PathS) = vbNullString Then     
 ' else do not bother
   Dim LI&, MYPath$, BuildPath$, PathStrArray$()
   PathStrArray = Split(PathS, "")
      BuildPath = PathStrArray(0) & ""    '
      If Dir(BuildPath) = vbNullString Then 
' trap problem of no drive :  path given
         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 If 
 ' was already there
End Sub
' use like
'MakeAllDir "K:biljoanJohno"
'MakeAllDir "K:biljoanFredso"
'MakeAllDir "K:biltomwattom"
'MakeAllDir "K:bilherbwatherb"
'MakeAllDir "K:bilherbJim"
'MakeAllDir "biljoanwat" ' default drive