Есть ли способ создать папку и подпапки в Excel VBA?
Хорошо, для тех, кто в курсе, кто является мастерами в Excel VBA, у меня есть выпадающее меню компаний, которое заполняется списком на другой вкладке. Три столбца: Компания, Номер задания и Номер детали.
Что я имею в виду, так это то, что при создании задания мне нужна папка для указанной компании, а затем подпапка, созданная на основе указанного номера детали. Так что если вы идете по пути, это будет выглядеть так:
C:\Images\Company Name\Part Number\
Теперь, если существует либо название компании, либо номер детали, не создавайте и не перезаписывайте старое. Просто перейдите к следующему шагу. Таким образом, если обе папки существуют, ничего не происходит, если одна или обе не существуют, создайте как требуется.
Имеет ли это смысл?
Если кто-то может помочь мне понять, как это работает и как заставить это работать, это будет с благодарностью. Еще раз спасибо.
Другой вопрос, если это не слишком много, есть ли способ сделать так, чтобы он работал на Mac и ПК одинаково?
15 ответов
Один саб и две функции. Подпрограмма строит ваш путь и использует функции, чтобы проверить, существует ли путь, и создать, если нет. Если полный путь уже существует, он просто пройдет мимо. Это будет работать на ПК, но вам придется проверить, что нужно изменить, чтобы работать и на 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
Еще одна простая версия, работающая на ПК:
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
Я нашел гораздо лучший способ сделать то же самое, меньше кода, гораздо более эффективный. Обратите внимание, что "" "" должен указывать путь в случае, если он содержит пробелы в имени папки. Командная строка mkdir создает любую промежуточную папку, если необходимо, чтобы существовал весь путь.
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
Здесь есть несколько хороших ответов, поэтому я просто добавлю некоторые улучшения процесса. Лучший способ определить, существует ли папка (не использует объекты FileSystemObject, которые разрешено использовать не всем компьютерам):
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
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
Для тех, кто ищет кроссплатформенный способ, работающий как на 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
В AutoCad VBA это работает как очарование, и я взял его с форума Excel. Я не знаю, почему вы все так усложняете?
ЧАСТО ЗАДАВАЕМЫЕ ВОПРОСЫ
Вопрос: я не уверен, что определенный каталог уже существует. Если он не существует, я хотел бы создать его с использованием кода VBA. Как я могу это сделать?
Ответ: Вы можете проверить, существует ли каталог, используя код VBA ниже:
(Цитаты ниже опущены, чтобы избежать путаницы в программном коде)
If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then
MkDir "c:\TOTN\Excel\Examples"
End If
Вот короткая подпрограмма без обработки ошибок, которая создает подкаталоги:
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
Никогда не пробовал с не 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
Все остальные ответы излишне сложны! Вы можете создать все дерево папок рекурсивно с помощью двух строк кода, проверьте это:
Public Sub MkDir_recursive(ByVal folder As String)
'Dim fso As Object : Set fso = CreateObject("Scripting.FileSystemObject")
Dim fso As New FileSystemObject 'If this throws an error, use above declaration instead
' Create parent folder if necessary (recursive)
If Not fso.FolderExists(fso.GetParentFolderName(folder)) Then MkDir_recursive fso.GetParentFolderName(folder)
If Not fso.FolderExists(folder) Then fso.CreateFolder folder 'All subfolders exist when we get here.
End Sub
Подпрограмма проверяет, не существует ли родительская папка, и в этом случае вызывает ту же подпрограмму, что и родительская папка, которая делает то же самое снова и снова. Это продолжается до тех пор, пока папка не существует или не достигнет корневой папки (которая будет существовать всегда). Когда
Примечание. Также работает с папками UNC (например, \\server\myshare\folder).
У меня нет доступа к MAC-адресу, но вы можете использовать ту же концепцию, она очень проста.
Это рекурсивная версия, которая работает как с буквенными дисками, так и с 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
Я знаю, что на этот вопрос ответили, и уже было много хороших ответов, но для людей, которые приходят сюда и ищут решение, я мог бы в конечном итоге опубликовать то, с чем я согласился.
Следующий код обрабатывает оба пути к диску (например, "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
Я надеюсь, что кто-то может найти это полезным. Наслаждайтесь!:-)
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