有没有一种方法来创建一个文件夹和子文件夹在Excel VBA？(Is there a way to

好吧，对于那些在知道是在Excel VBA的主人，我有一个下拉由另一个选项卡的列表填充公司菜单。 三列，公司，职位＃和型号。

我所去的是创建工作，当我需要说公司要创建一个文件夹，然后根据断的说零件号创建子文件夹。 所以，如果你去了会是这样的路径：

C:\Images\Company Name\Part Number\

现在，如果这两家公司的名称或型号存在不创建或覆盖旧的。 刚进入下一步骤。 所以，如果存在这两个文件夹没有任何反应，如果一方或双方不存在创建要求。

这是否有意义？

如果有人可以帮助我了解如何工作，以及如何使其工作，将不胜感激。 再次感谢。

另一个问题是，如果它不是太多是有办法使它所以它适用于Mac和PC一样吗？

Answer 1:

一个子和两个功能。 子建立你的路径，并使用功能，以检查是否存在的路径，如果没有建立。 若全部路径已经存在，它将只是传递。 这将工作在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 2:

另一个简单的版本在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 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 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

Answer 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

Answer 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

Answer 7:

决不非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

Answer 8:

这里是没有创建子目录错误处理短子：

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 9:

我知道这已经回答了，并出现了许多很好的答案了，但对于谁来到这里寻找一个解决方案，我会寄我有最终定居的人。

下面的代码同时处理路径驱动器（如“C：\用户...”）和服务器地址（样式：“\服务器\路径..”），它需要一个路径作为参数，并自动去除任何从它的文件名（使用“\”结尾，如果它已经是一个目录路径），并将其返回，如果由于某种原因该文件夹无法创建虚假。 哦，是的，这也创造了分分分目录，如果这个请求。

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 10:

        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

结束小组

“上述马丁斯循环版本比我的递归版本更好”等完善以下

子MakeAllDir（路径$）

“格式 ”K：\ firstfold \ SECF \ fold3“

如果风向（路径）= vbNullString然后

“其他人不要打扰

昏暗的LI＆，mypath中$，$构建路径，PathStrArray $（）

PathStrArray =分段（路径， “\”）

  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

万一

“已经摆在那里

结束小组

'使用像' MakeAllDir “d：\ BIL \琼\ Johno”

“MakeAllDir “d：\ BIL \琼\ Fredson”

“MakeAllDir “K：\汽车\汤姆\ wattom”

“MakeAllDir “K：\ BIL \药草\ watherb”

“MakeAllDir “K：\ BIL \药草\吉姆”

“MakeAllDir“BIL \琼\笏”'默认驱动器

文章来源: Is there a way to create a folder, and sub folders in Excel VBA?