有没有办法在Excel VBA中创build文件夹和子文件夹？
好吧，对于那些知道在Excel VBA中是主人的人，我有一个由另一个选项卡上的列表填充的公司的下拉菜单。 三列，公司，工作编号和零件编号。
我所做的是当创build一个作业时，我需要一个用于创build所述公司的文件夹，然后是基于所述部件号创build的子文件夹。 所以如果你沿着这条路走下去就像这样：
C:\Images\Company Name\Part Number\
现在，如果公司名称或零件编号存在，则不要创build或覆盖旧的。 只需进入下一步。 因此，如果两个文件夹都不存在，则根据需要创build一个或两个文件夹。
这有道理吗？
如果有人能帮助我理解这是如何工作，以及如何使其工作，将不胜感激。 再次感谢。
另一个问题，如果它不是太多，是否有办法使它在Mac和PC上的作品相同？
一个子和两个function。 子build立你的path，并使用函数来检查path是否存在，如果没有创build。 如果完整的path已经存在，它只会传递。 这将在个人电脑上工作，但你将不得不检查什么需要修改，以在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
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
我发现了一个更好的方法来做同样的事情，更less的代码，更有效率。 请注意，如果文件夹名称中包含空格，“”“将引用该path。 命令行mkdir创build任何中间文件夹，如果需要使整个path存在。
If Dir(YourPath, vbDirectory) = "" Then Shell ("cmd /c mkdir """ & YourPath & """") End If
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
这里有一些很好的答案，所以我只是添加一些stream程改进。 确定文件夹是否存在的更好方法（不使用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
这就像在AutoCad VBA中的魅力，我从一个Excel论坛抓住它。 我不知道你们为什么这么复杂？
经常问的问题
问题：我不确定一个特定的目录是否已经存在。 如果它不存在，我想用VBA代码创build它。 我怎样才能做到这一点？
答：您可以使用下面的VBA代码来testing目录是否存在：
（为避免编程代码的混淆，省略下面的引用）
If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then MkDir "c:\TOTN\Excel\Examples" End If
从来没有尝试与非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
这里是短的子没有error handling，创build子目录：
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
我知道这已经得到了回答，已经有很多好的答案，但是对于来这里寻找解决办法的人来说，我最终可以发布我已经解决的问题。
下面的代码处理一个驱动器的path（比如“C：\ Users …”）和服务器地址（样式：“\ Server \ Path ..”），它将path作为参数，文件名（如果已经是目录path，则在末尾使用“\”），如果由于某种原因无法创build文件夹，则返回false。 哦，是的，它也创build子子目录，如果这是请求。
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
我希望有人可能会觉得这有用。 请享用！ 🙂
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
结束小组