У меня есть выпадающее меню компаний, которое заполняется списком на другом листе. Три столбца: компания, задание № и номер детали.
При создании задания мне нужна папка для указанной компании и вложенная папка для указанного номера детали.
Если вы пойдете по пути, это будет выглядеть следующим образом:
C:\Images\Company Name\Part Number\
Если название компании или номер детали уже существует, не создавайте и не перезаписывайте старое название. Просто перейдите к следующему шагу. Таким образом, если обе папки существуют, ничего не произойдет, если одна или обе не существуют, создайте их как нужно.
Другой вопрос, есть ли способ сделать так, чтобы это работало на Mac и 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
Одна подсистема и две функции. 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
Я нашел гораздо лучший способ делать то же самое, меньше кода, гораздо более эффективным. Обратите внимание, что "" и" и" Это цитата путь в случае, если оно содержит пробелы в имени папки. Командная строка команды 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
Есть несколько хороших ответов здесь, так что я просто добавить некоторые улучшения процесса. Лучший способ определить, если папка существует (не использовать 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. Я не'т знаю, почему вы все все усложняют?
часто задаваемые вопросы
вопрос: Я'м не уверен, если существует определенный каталог. Если это не'Т Я'd, как создать его с помощью кода VBA. Как я могу это сделать?
В ответ: Вы можете проверить, чтобы увидеть, если существует каталог, с помощью кода VBA ниже:
(Ниже цитаты опущены, чтобы избежать путаницы кода программирования)
If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then
MkDir "c:\TOTN\Excel\Examples"
End If
'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
Никогда не пробовала с системами Windows, но здесь's одна у меня есть в моей библиотеке, довольно простой в использовании. Никакой специальной справочной библиотеки требуется.
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
Вот короткий sub без обработки ошибок, который создает подкаталоги:
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
Я знаю, что это был дан ответ и было много хороших ответов, но для людей, которые приезжают сюда и искать решение, я могу отправить то, что я поселился с в конце концов.
Следующий код обрабатывает как пути к диску (как-то "C:\Users...") и адрес сервера (в стиле: " в\сервер\путь..") Смотрите, он принимает путь в качестве аргумента и автоматически удаляет любые имена файлов из нее (использование " в\" и в конце, если это's уже путь к каталогу) и возвращает 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
Я надеюсь, что кто-то может найти это полезным. Наслаждайтесь! :-)
Это рекурсивная версия, которая работает с дисков так же как 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
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 тогда
' еще не беспокоят
Дим ли&, путь mypath$, buildpath по$, 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 и"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, что "Я\біл Джоан Ват&; ' диск по умолчанию