blocks|key|226357|text|一个子函数和两个函数。sub构建您的路径，并使用函数检查路径是否存在，如果不存在，则创建。如果完整路径已经存在，它将被忽略。这将在PC上工作，但你必须检查哪些需要修改才能在Mac上工作。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|226358|'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|code-block|syntax|javascript|226359|entityMap^0|0|0^^$0|@$1|2|3|4|5|6|7|I|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|J|8|@]|9|@]|A|$E|F]]|$1|G|3|-4|5|6|7|K|8|@]|9|@]|A|$]]]|H|$]]

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.

<pre><code>'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 &amp; strComp) Then 
'company doesn't exist, so create full path
 FolderCreate strPath &amp; strComp &amp; "\" &amp; strPart
Else
'company does exist, but does part folder
 If Not FolderExists(strPath &amp; strComp &amp; "\" &amp; strPart) Then
 FolderCreate strPath &amp; strComp &amp; "\" &amp; 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: " &amp; path &amp; ". 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
</code></pre>

blocks|key|2880802|text|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|type|code-block|depth|inlineStyleRanges|entityRanges|data|syntax|javascript|2880803|unstyled|entityMap^0|0^^$0|@$1|2|3|4|5|6|7|G|8|@]|9|@]|A|$B|C]]|$1|D|3|-4|5|E|7|H|8|@]|9|@]|A|$]]]|F|$]]

<pre><code>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\" &amp; fldrname
 If Not fso.FolderExists(fldrpath) Then
 fso.createfolder (fldrpath)
 End If
End Sub
</code></pre>

blocks|key|2880811|text|下面是不带错误处理的短子目录创建子目录：|type|unstyled|depth|inlineStyleRanges|entityRanges|data|2880812|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|code-block|syntax|javascript|2880813|entityMap^0|0|0^^$0|@$1|2|3|4|5|6|7|I|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|J|8|@]|9|@]|A|$E|F]]|$1|G|3|-4|5|6|7|K|8|@]|9|@]|A|$]]]|H|$]]

Here's short sub without error handling that creates subdirectories:

<pre><code>Public Function CreateSubDirs(ByVal vstrPath As String)
 Dim marrPath() As String
 Dim mint As Integer

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

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

 MkDir vstrPath

 For mint = mint To UBound(marrPath) 'create directories
 vstrPath = vstrPath &amp; marrPath(mint) &amp; "\"
 MkDir vstrPath
 Next mint
End Function
</code></pre>

blocks|key|2880831|text|我发现了一种更好的方法来做同样的事情，代码更少，效率更高。请注意，“用于引用路径，以防文件夹名称中包含空格。如果需要，命令行mkdir会创建任何中间文件夹，以使整个路径存在。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|2880832|If+Dir(YourPath,+vbDirectory)+=+""+Then
++++Shell+("cmd+/c+mkdir+"""+&+YourPath+&+"""")
End+If|code-block|syntax|javascript|2880833|entityMap^0|0|0^^$0|@$1|2|3|4|5|6|7|I|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|J|8|@]|9|@]|A|$E|F]]|$1|G|3|-4|5|6|7|K|8|@]|9|@]|A|$]]]|H|$]]

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.

<pre class="lang-vb prettyprint-override"><code>If Dir(YourPath, vbDirectory) = "" Then
 Shell ("cmd /c mkdir """ &amp; YourPath &amp; """")
End If
</code></pre>

blocks|key|2880851|text|我从来没有在非Windows系统上尝试过，但我的库中有一个，非常容易使用。不需要特殊的库参考。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|2880852|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|code-block|syntax|javascript|2880853|entityMap^0|0|0^^$0|@$1|2|3|4|5|6|7|I|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|J|8|@]|9|@]|A|$E|F]]|$1|G|3|-4|5|6|7|K|8|@]|9|@]|A|$]]]|H|$]]

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.

<pre><code>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 &amp; FolderArray(i) &amp; "\"
 If Not fs.FolderExists(Folder) Then
 fs.CreateFolder (Folder)
 End If
 Next
 CreateFolder = True
hell:
End Function
</code></pre>

blocks|key|3094902|text|这在AutoCad+VBA中就像一个护身符，我是从一个excel论坛上拿来的。我不知道为什么你们都把事情搞得这么复杂？|type|unstyled|depth|inlineStyleRanges|entityRanges|data|3094903|3094904|常见问题|blockquote|3094905|3094906|问:我不确定特定的目录是否已经存在。如果它不存在，我想使用VBA代码创建它。我该怎么做呢？|3094907|答:您可以使用下面的VBA代码测试目录是否存在：|3094908|3094909|(省略下面的引号，以免混淆编程代码)|3094910|3094911|If+Len(Dir("c:\TOTN\Excel\Examples",+vbDirectory))+=+0+Then

+++MkDir+"c:\TOTN\Excel\Examples"

End+If|code-block|syntax|javascript|3094912|3094913|http://www.techonthenet.com/excel/formulas/mkdir.php|offset|length|3094914|entityMap|0|LINK|mutability|MUTABLE|url^0|0|0|0|0|0|0|0|0|0|0|0|0|1G|0|0^^$0|@$1|2|3|4|5|6|7|15|8|@]|9|@]|A|$]]|$1|B|3|-4|5|6|7|16|8|@]|9|@]|A|$]]|$1|C|3|D|5|E|7|17|8|@]|9|@]|A|$]]|$1|F|3|-4|5|6|7|18|8|@]|9|@]|A|$]]|$1|G|3|H|5|6|7|19|8|@]|9|@]|A|$]]|$1|I|3|J|5|6|7|1A|8|@]|9|@]|A|$]]|$1|K|3|-4|5|6|7|1B|8|@]|9|@]|A|$]]|$1|L|3|M|5|6|7|1C|8|@]|9|@]|A|$]]|$1|N|3|-4|5|6|7|1D|8|@]|9|@]|A|$]]|$1|O|3|P|5|Q|7|1E|8|@]|9|@]|A|$R|S]]|$1|T|3|-4|5|6|7|1F|8|@]|9|@]|A|$]]|$1|U|3|V|5|6|7|1G|8|@]|9|@$W|1H|X|1I|1|1J]]|A|$]]|$1|Y|3|-4|5|6|7|1K|8|@]|9|@]|A|$]]]|Z|$10|$5|11|12|13|A|$14|V]]]]

This works like a charm in AutoCad VBA and I grabbed it from an excel forum. I don't know why you all make it so complicated?
<blockquote>
FREQUENTLY ASKED QUESTIONS
Question: I'm not sure if a particular directory exists already. If it doesn't exist, I'd like to create it using VBA code. How can I do this?
Answer: You can test to see if a directory exists using the VBA code below:
</blockquote>
(Quotes below are omitted to avoid confusion of programming code)
<hr />
<pre><code>If Len(Dir(&quot;c:\TOTN\Excel\Examples&quot;, vbDirectory)) = 0 Then

 MkDir &quot;c:\TOTN\Excel\Examples&quot;

End If
</code></pre>
<hr />
<a href="http://www.techonthenet.com/excel/formulas/mkdir.php" rel="nofollow noreferrer">http://www.techonthenet.com/excel/formulas/mkdir.php</a>

blocks|key|223627|text|另一个运行在PC上的简单版本：|type|unstyled|depth|inlineStyleRanges|entityRanges|data|223628|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|code-block|syntax|javascript|223629|entityMap^0|0|0^^$0|@$1|2|3|4|5|6|7|I|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|J|8|@]|9|@]|A|$E|F]]|$1|G|3|-4|5|6|7|K|8|@]|9|@]|A|$]]]|H|$]]

Another simple version working on PC:

<pre><code>Sub CreateDir(strPath As String)
 Dim elm As Variant
 Dim strCheckPath As String

 strCheckPath = ""
 For Each elm In Split(strPath, "\")
 strCheckPath = strCheckPath &amp; elm &amp; "\"
 If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
 Next
End Sub
</code></pre>

blocks|key|223631|text|这里有一些很好的答案，所以我只会添加一些流程改进。确定文件夹是否存在的更好方法(不使用FileSystemObjects，因为并非所有计算机都允许使用它)：|type|unstyled|depth|inlineStyleRanges|entityRanges|data|223632|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|code-block|syntax|javascript|223633|同样的，|223634|Function+FileExists(FileName+As+String)+As+Boolean
+++++If+Dir(FileName)+<>+""+Then+FileExists+=+True+Else+FileExists+=+False
EndFunction|223635|entityMap^0|0|0|0|0^^$0|@$1|2|3|4|5|6|7|M|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|N|8|@]|9|@]|A|$E|F]]|$1|G|3|H|5|6|7|O|8|@]|9|@]|A|$]]|$1|I|3|J|5|D|7|P|8|@]|9|@]|A|$E|F]]|$1|K|3|-4|5|6|7|Q|8|@]|9|@]|A|$]]]|L|$]]

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

<pre><code>Function FolderExists(FolderPath As String) As Boolean
 FolderExists = True
 On Error Resume Next
 ChDir FolderPath
 If Err &lt;&gt; 0 Then FolderExists = False
 On Error GoTo 0
End Function
</code></pre>

Likewise,

<pre><code>Function FileExists(FileName As String) As Boolean
 If Dir(FileName) &lt;&gt; "" Then FileExists = True Else FileExists = False
EndFunction
</code></pre>

blocks|key|228658|text|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|type|code-block|depth|inlineStyleRanges|entityRanges|data|syntax|javascript|228659|unstyled|entityMap^0|0^^$0|@$1|2|3|4|5|6|7|G|8|@]|9|@]|A|$B|C]]|$1|D|3|-4|5|E|7|H|8|@]|9|@]|A|$]]]|F|$]]

<pre><code>Sub MakeAllPath(ByVal PS$)
 Dim PP$
 If PS &lt;&gt; "" 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) &lt;&gt; ":" 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&amp;, MYPath$, BuildPath$, PathStrArray$()

 PathStrArray = Split(PathS, "\")

 BuildPath = PathStrArray(0) &amp; "\" '

 If Dir(BuildPath) = vbNullString Then 

' trap problem of no drive :\ path given

 If vbYes = MsgBox(PathStrArray(0) &amp; "&lt; not there for &gt;" &amp; PathS &amp; " try to append to " &amp; CurDir, vbYesNo) Then
 BuildPath = CurDir &amp; "\"
 Else
 Exit Sub
 End If
 End If
 '
 ' loop through required folders
 '
 For LI = 1 To UBound(PathStrArray)
 BuildPath = BuildPath &amp; PathStrArray(LI) &amp; "\"
 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
</code></pre>

blocks|key|226440|text|我知道这个问题已经得到了回答，而且已经有了很多好的答案，但是对于那些来这里寻找解决方案的人来说，我可以把我最终解决的问题发布出来。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|226441|下面的代码处理驱动器的两个路径(如"C:\Users...")和一个服务器地址(样式："\+server+\+path+..")，它接受一个路径作为参数，并自动从其中剥离任何文件名(如果它已经是一个目录路径，则在末尾使用"\“)，如果由于某种原因无法创建文件夹，它将返回false。哦，是的，如果需要的话，它还会创建子目录。|226442|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+%2B+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|code-block|syntax|javascript|226443|我希望有人会觉得这很有用。尽情享受！:-)|226444|entityMap^0|0|0|0|0^^$0|@$1|2|3|4|5|6|7|M|8|@]|9|@]|A|$]]|$1|B|3|C|5|6|7|N|8|@]|9|@]|A|$]]|$1|D|3|E|5|F|7|O|8|@]|9|@]|A|$G|H]]|$1|I|3|J|5|6|7|P|8|@]|9|@]|A|$]]|$1|K|3|-4|5|6|7|Q|8|@]|9|@]|A|$]]]|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.

<pre><code>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) &lt; 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 &amp; sect(i) &amp; Application.PathSeparator
 Next ' i

 ' check if this path exists:
 If (Dir(cPath, vbDirectory) &lt;&gt; 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 &amp; sect(i) &amp; Application.PathSeparator
 Next ' i

 ' create the directory:
 MkDir cPath

Next ' pos

CreatePathTo = True
Exit Function

Error01:

End Function
</code></pre>

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

blocks|key|226446|text|这是一个递归版本，可以与字母驱动器以及UNC一起使用。我使用了错误捕捉来实现它，但如果有人可以不使用它，我会很感兴趣的。这种方法从分支到根工作，因此当您在目录树的根和较低部分没有权限时，它在某种程度上是可用的。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|226447|'+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|code-block|syntax|javascript|226448|entityMap^0|0|0^^$0|@$1|2|3|4|5|6|7|I|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|J|8|@]|9|@]|A|$E|F]]|$1|G|3|-4|5|6|7|K|8|@]|9|@]|A|$]]]|H|$]]

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. 

<pre><code>' 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) &gt; 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
</code></pre>

blocks|key|2880915|text|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|type|code-block|depth|inlineStyleRanges|entityRanges|data|syntax|javascript|2880916|unstyled|entityMap^0|0^^$0|@$1|2|3|4|5|6|7|G|8|@]|9|@]|A|$B|C]]|$1|D|3|-4|5|E|7|H|8|@]|9|@]|A|$]]]|F|$]]

<pre><code>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
</code></pre>

blocks|key|3094948|text|对于那些寻找在Windows和Mac上都能工作的跨平台方式的人来说，下面的方法是可行的：|type|unstyled|depth|inlineStyleRanges|entityRanges|data|3094949|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|code-block|syntax|javascript|3094950|entityMap^0|0|0^^$0|@$1|2|3|4|5|6|7|I|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|J|8|@]|9|@]|A|$E|F]]|$1|G|3|-4|5|6|7|K|8|@]|9|@]|A|$]]]|H|$]]

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

<pre><code>Sub CreateDir(strPath As String)
 Dim elm As Variant
 Dim strCheckPath As String

 strCheckPath = ""
 For Each elm In Split(strPath, Application.PathSeparator)
 strCheckPath = strCheckPath &amp; elm &amp; Application.PathSeparator
 If (Len(strCheckPath) &gt; 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 &lt;&gt; 0 Then FolderExists = False
 On Error GoTo 0
End Function
</code></pre>

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:

<blockquote>
 C:\Images\Company Name\Part Number\
</blockquote>

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?

Create a folder and sub folder in Excel VBA

我有一个公司的下拉菜单，由另一个工作表上的列表填充。三列:公司、职务编号和部件号。当一个工作是创建的时候，我需要一个文件夹，说公司和子文件夹说，零件编号。如果你沿着这条路走下去，它看起来会像这样： C：\图像\公司名称\零件号\如果公司名称或部件号存在，请不要创建或覆盖旧名称或部件号。只需转到下一步。因此，如果两个文件...

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

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

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

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

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