好的，对于那些知道自己是Excel VBA主人的人，我有一个公司的下拉菜单，由另一个标签上的列表填充。三列，公司，工作号和部件号。
我发现的是，当创建一个作业时，我需要一个文件夹来创建所述公司，然后根据所述部件号创建一个子文件夹。因此，如果沿着这条路走下去，它将会是这样的：
C:\Images\Company Name\Part Number\
现在，如果存在公司名称或部件号，则不创建或覆盖旧名称。转到下一步。因此，如果两个文件夹都不存在，则如果一个或两个不存在则按要求创建。
这有意义吗？
如果有人可以帮助我了解其工作原理以及如何使其发挥作用，我们将不胜感激。再次感谢。
另一个问题，如果不是太多，有没有办法让它在Mac和PC上运行相同？
答案 0 :(得分：33)
另一个在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
答案 1 :(得分：26)
一个子功能和两个功能。 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
答案 2 :(得分：9)
我找到了一种更好的方法来做同样的事情，更少的代码，更有效率。请注意，“”“”是引用路径，以防它在文件夹名称中包含空格。如有必要，命令行mkdir会创建任何中间文件夹，以使整个路径存在。
If Dir(YourPath, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & YourPath & """")
End If
答案 3 :(得分：5)
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
答案 4 :(得分：3)
这里有一些很好的答案，所以我只想添加一些流程改进。确定文件夹是否存在的更好方法（不使用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
答案 5 :(得分：2)
这就像AutoCad VBA中的魅力一样，我从excel论坛中抓取它。我不知道为什么你们都这么复杂？
经常提出的问题
问题：我不确定某个特定目录是否存在。如果它不存在，我想使用VBA代码创建它。我怎么能这样做？
答案：您可以使用下面的VBA代码测试目录是否存在：
（省略以下引用以避免混淆编程代码）
If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then
MkDir "c:\TOTN\Excel\Examples"
End If
答案 6 :(得分：0)
这是创建子目录的没有错误处理的短子：
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
答案 7 :(得分：0)
从未尝试使用非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
答案 8 :(得分：0)
我知道这已经得到了解答，并且已经有很多好的答案，但是对于那些来到这里寻找解决方案的人来说，我可以发布我最终解决的问题。
以下代码处理驱动器的两个路径（例如＆＃34; C：\ Users ...＆＃34;）和服务器地址（样式：＆＃34; \ Server \ Path ..＆＃ 34;），它将路径作为参数并自动从中删除任何文件名（如果它已经是目录路径，则使用＆＃34; \＆＃34;最后）如果是，则返回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
我希望有人可能觉得这很有用。请享用！ ： - ）
答案 9 :(得分：0)
这是递归版本，可与字母驱动器以及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
答案 10 :(得分：0)
'requires reference to Microsoft Scripting Runtime
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
答案 11 :(得分：0)
对于那些希望在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
答案 12 :(得分：-1)
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循环版本比MY递归版本更好 '所以提高到以下
Sub MakeAllDir（PathS $）
'format“K：\ firstfold \ secf \ fold3”
如果Dir（PathS）= vbNullString那么
'否则不要打扰
Dim LI＆amp;，MYPath $，BuildPath $，PathStrArray $（）
PathStrArray = Split（PathS，“\”）
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
结束如果
'已经存在了
End Sub
'使用喜欢 '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”'默认驱动器