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

Posted 2023-02-23

【中文标题】在 Excel VBA 中创建文件夹和子文件夹

【英文标题】：Create a folder and sub folder in Excel VBA

【发布时间】：2012-06-03 22:52:41

【问题描述】：

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

创建工作后，我需要一个用于所述公司的文件夹和一个用于所述部件号的子文件夹。

如果你沿着这条路走，它会是这样的：

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

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

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

【问题讨论】：

EXCEL: Create folder hierarchy from spreadsheet data?的可能重复

除了它需要从三列中取出两列才能工作......你链接到的那个虽然可以工作，但需要所有数据而不是特定数据..

@assylias 链接效果很好，除了您需要稍微修改代码（逻辑）。使用伪代码（英文作为代码）-> If Exists C:\Images[Company] then If Exists C:\Images[Company][Part] Then Exit Else Create C:\Images[Company][Part] Else Create C :\图片[公司][部分]。您可以使用 FileSystemObject 的 Folder 方法查看您的目录是否存在，并使用变量根据单元格值设置公司和零件。

我建议分阶段构建。你有我刚刚给你的 -> 它有一些“内置错误检查”和其他代码。然后，您可以将其设置为在 PC 上工作，添加您想要的任何其他错误检查（在不知道可能性的情况下很难进行错误检查 -> 虽然我能想到一些）。在你让它在 PC 上运行后，你可以找出在 mac 中会有什么不同并调整代码以适应它。

谢谢，要回答这样一个问题：要使 Mac 和 PC 之间的路径通用，请使用 Application.PathSeparator。那应该有帮助。我记得有几个人帮助我通过一个脚本使用 Excel VBA 制作外部日志。

【参考方案1】：

对于那些寻找在 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

【参考方案2】：

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

【讨论】：

请解释为什么这个答案比 7 年前给出的其他 12 个答案更好。

欢迎来到 Stack Overflow！这是How to Answer 的指南。仅代码的答案被认为是低质量的：请务必解释您的代码的作用以及它如何解决问题。

这个解决方案更干净。它更多地依赖于 Windows 文件脚本主机功能，而不是 3 个笨重的 vba 模块。它得到了我的投票。

【参考方案3】：

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

【讨论】：

如果需要更多的子文件夹级别，这将失败。虽然如果只需要创建一个文件夹，它可能会起作用。

【参考方案4】：

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:\firstfold\secf\fold3"

  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:\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" ' default drive

【参考方案5】：

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

【讨论】：

不起作用 - MkDir 无法创建父目录

【参考方案6】：

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

以下代码处理驱动器的路径（如“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

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

【参考方案7】：

这是一个没有错误处理的简短子目录：

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】：

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

【参考方案9】：

这就像 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

【讨论】：

你自己的链接指出mkdir不能创建父目录。

【参考方案10】：

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

【讨论】：

被低估的解决方案

请注意 strPath 在最后的“\”之后不包含文件名，否则此代码将创建一个具有该名称的文件夹。

很棒的解决方案。一个小小的改进是使用Dir(strCheckPath, vbDirectory) = ""而不是调用Len。

这不适用于以 \\ 开头的 UNC 路径。我添加了两个检查，但感觉就像一个 hack： If strCheckPath "\" And strCheckPath "\\" Then

【参考方案11】：

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

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

【讨论】：

这对于创建文件夹非常有用，但它不会等待命令结束。因此，如果您尝试在此之后将文件复制到新文件夹，它将失败。

只要在它不存在的时候再放一个命令来检查，不要复制任何东西。

如果不小心 YourPath 是 "//" 或 "\\" - 它会挂起。如果像"::" 这样的东西 - 它会继续，会失败，你不会知道它失败了。如果只是一个字符串（不是路径），例如"ABBA" - 文件夹将在您的 CurDir 中创建（与文件的文件夹不同的位置）。检查文件夹是否存在的正确方法是FileSystemObject.FolderExists(YourPath)

@waternova 我通过使用 WScript 对象解决了这个问题：Set wsh = CreateObject("WScript.Shell"); wsh.Run "cmd /c mkdir """ & YourPath & """", 0, True 这将等到 cmd 完成

【参考方案12】：

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

【参考方案13】：

一个子和两个函数。子构建您的路径并使用函数检查路径是否存在，如果不存在则创建。如果完整路径已经存在，它将直接通过。 这将在 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

【讨论】：

有没有办法让Application.PathSeparator 使用此代码，以便在 Mac 和 PC 上通用？

是的，用 Application.PathSeparator 替换 "\" 的每个实例（通常是 PC 路径分隔符） - 所以 "C:\Images\" 变为 "C:" & Application.PathSeparator & "Images" & Application.PathSeparator ...或者您可以将 Application.PathSepator 设置为变量，并在整个过程中使用变量名。这样可能更干净:)

我一直在努力让它工作，我遇到的唯一问题是输入Application.PathSeparator的代码，在Mac上没有C盘，它是 \Volumes\Drive Name\Path\...

看到这个网站rondebruin.nl/mac.htm ...罗恩很不错。您可以先测试一下您使用的是 Mac 还是 PC，然后相应地设置路径变量。像 IF MAC Then strPath = \\Volumes\Drive\Name\Path ELSE strPath = "C:\..." END IF。如果您需要帮助进行设置，请发布另一个问题。

谢谢！因为 Excel 2010 中有一个函数 StrComp，所以它就像一个小改动的魅力。