VBA Создать папку на основе пути сохранения, расположенного в ячейке. Vba excel создание папки

vba - Путь не найден при создании папки в Excel VBA

У меня есть подпрограмма VBA, чтобы перебирать строки таблицы Excel и копировать файл из пути, хранящегося в одной ячейке, в путь, состоящий из информации из нескольких других ячеек. Большую часть времени вам нужно будет создать папку для файла, но только на один уровень глубже (не пытаюсь. Однако, когда я запустил ее, иногда я получаю ошибку 76 path not found выполнения 76 path not found удается 76 path not found. Когда я смотрю на папку в Windows Проводник откроется, но он слегка прозрачен (например, файл, который записывается).

Почему я fso.Createfolder strDirPath этой ошибкой в fso.Createfolder strDirPath? Я предполагаю, что это связано с выбором времени, потому что, когда я снова запускаю скрипт, он может передать файл просто отлично. Есть ли способ проверить, что папка готова?

Sub CopyFiles() ' Copy to location [root_folder]\company_name\contract_no'_'file_name Dim strRootFolder, strCompany, strContract, strFileName, strDirPath Dim strFullPath, strFromPath, intRow strRootFolder = "C:\...\DestinationFolder\" intRow = 2 Dim fso As New FileSystemObject 'Loop through rows Range("C" & 2).Select 'First row to check (column always filled) Do Until IsEmpty(ActiveCell) ' Loop through till end of spreadsheet strFromPath = objSheet.Range("C" & intRow).Value ' Replace "/" characters in company names with "_" strCompany = Replace(objSheet.Range("E" & intRow).Value, "/", "_") strContract = objSheet.Range("A" & intRow).Value & "_" ' Replace "#" in file names with "0" strFileName = Replace(objSheet.Range("B" & intRow).Value, "#", "0") strDirPath = strRootFolder & strCompany & "\" strFullPath = strDirPath & strContract & strFileName ' Create directory if it does not exist If Not fso.FolderExists(strDirPath) Then fso.Createfolder strDirPath ' !!! This is where the error is !!! End If ' Copy file fso.CopyFile strFromPath, strFullPath, False intRow = intRow + 1 ActiveCell.Offset(1, 0).Select ' drop one to check if filled Loop End Sub

Примечание. Это происходит не из-за обратной косой черты в имени каталога. Код заменяет обратную косую черту и на входе нет косой черты.

задан Chic 09 дек. '14 в 18:04 источник поделиться

qaru.site

Есть ли способ создать папку и подпапки в Excel VBA? MS Excel онлайн

Хорошо, для тех, кто знает, что есть мастера в Excel VBA, у меня есть выпадающее меню компаний, которое заполняется списком на другой вкладке. Три столбца, компания, номер задания и номер детали.

То, что я делаю, заключается в том, что при создании задания мне нужна папка для указанной компании, которая будет создана, а затем подпапка, созданная на основе указанного номера детали. Поэтому, если вы спуститесь по пути, это будет выглядеть так:

Теперь, если имя какой-либо компании или номер детали не создаются или перезаписываются старым. Просто переходите к следующему шагу. Поэтому, если обе папки существуют, ничего не происходит, если один или оба не существуют, создайте по мере необходимости.

Если кто-то может помочь мне понять, как это работает и как заставить его работать, мы будем очень благодарны. Еще раз спасибо.

Другой вопрос, если это не так много, есть способ сделать так, чтобы он работал на Mac и ПК одинаково?

Одна вспомогательная и две функции. Sub строит ваш путь и использует функции, чтобы проверить, существует ли путь и создать, если нет. Если полный путь уже существует, он просто пройдет. Это будет работать на ПК, но вам нужно будет проверить, что нужно изменить для работы на 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

Здесь есть несколько хороших ответов, поэтому я просто добавлю некоторые улучшения в процессе. Лучший способ определить, существует ли папка (не использует файлы 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. Как я могу это сделать?

Ответ. Вы можете проверить, существует ли каталог с помощью кода VBA ниже:

(Котировки ниже опущены, чтобы избежать путаницы программирования кода)

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then MkDir "c:\TOTN\Excel\Examples" End If

http://www.techonthenet.com/excel/formulas/mkdir.php

Никогда не пробовал работать с системами не 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 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 …») и адрес сервера (стиль: «\ 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

excel.bilee.com

vba - Excel VBA: создание списка подпапок и файлов в исходной папке

Я использую следующий код для перечисления всех файлов в папке хоста и вложенных папках. Код работает отлично, но знаете ли вы, как я могу обновить код, чтобы также указать некоторые атрибуты файла.

Sub file_list() Call ListFilesInFolder("W:\ISO 9001\INTEGRATED_PLANNING\", True) End Sub Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean) Dim FSO As Object Dim SourceFolder As Object Dim SubFolder As Object Dim FileItem As Object Dim r As Long Set FSO = CreateObject("Scripting.FileSystemObject") Set SourceFolder = FSO.getFolder(SourceFolderName) r = Range("A65536").End(xlUp).Row + 1 For Each FileItem In SourceFolder.Files Cells(r, 1).Formula = FileItem.Name r = r + 1 X = SourceFolder.Path Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.Subfolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub Function GetFileOwner(ByVal FilePath As String, ByVal FileName As String) Dim objFolder As Object Dim objFolderItem As Object Dim objShell As Object FileName = StrConv(FileName, vbUnicode) FilePath = StrConv(FilePath, vbUnicode) Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode)) If Not objFolder Is Nothing Then Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode)) End If If Not objFolderItem Is Nothing Then GetFileOwner = objFolder.GetDetailsOf(objFolderItem, 8) Else GetFileOwner = "" End If Set objShell = Nothing Set objFolder = Nothing Set objFolderItem = Nothing End Function

Я бы очень хотел это увидеть;

Столбец A = Хост-папка/подпапка

Столбец B = Имя файла

Столбец C = гиперссылка на файл

Это возможно?

У меня есть код, который создал гиперссылки, но я не знаю, как добавить к существующему коду.

Sub startIt() Dim FileSystem As Object Dim HostFolder As String HostFolder = "W:\ISO 9001\INTEGRATED_PLANNING\" Set FileSystem = CreateObject("Scripting.FileSystemObject") DoFolder FileSystem.GetFolder(HostFolder) End Sub Sub DoFolder(Folder) Dim SubFolder For Each SubFolder In Folder.Subfolders DoFolder SubFolder Next i = Cells(Rows.Count, 1).End(xlUp).Row + 1 Dim File For Each File In Folder.Files ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:= _ File.Path, TextToDisplay:=File.Name i = i + 1 Next End Sub задан SMORF 17 февр. '16 в 14:58 источник поделиться

qaru.site

vba - Excel vba Следующий номер счета с созданием папки автоматического каталога по месяцам

Я вижу, что вы пытаетесь сделать (хорошо организовывайте, автоматически) и это отличная цель.

У меня есть предложение альтернативной системы нумерации счетов (основанной на том, что я понимаю вашу ситуацию и уровень опыта), что значительно облегчит задачи (например, этот процесс автоматической подачи), а также упростит процесс в любое время вы (или особенно кто-либо еще) должны оглянуться назад на эти счета-фактуры. Существует ряд очевидных преимуществ (та же идея, что и метрика против имперского).

Идеальная система нумерации: (на мой взгляд)

Чтобы уменьшить путаницу: дайте каждому счету и имени файла одно и то же имя вместо имени файла с месяцем и
Поскольку вы хотите, чтобы размерность составляла от нескольких месяцев до нескольких лет (но не дней): укажите имя счета/файла, включающее все эти поля.
Сделать сортировку и найти эти логические (проще): поместить каждую "дату" в порядок наименьшего размера. Уникальный последовательный номер идет в самом конце.

Ваш образец кода был хорошим началом - у меня просто есть OCD, когда дело доходит до такого рода вещей, и создание нумерационной системы - важная задача. (Также это будет "дата-доказательство", и проверка ошибок по пути...

Это немного отличается от того, что у вас было, потому что вместо того, чтобы вы рассказывали код, какой номер следующего счета-фактуры, он сообщает вам (путем вычисления следующего числа в последовательности на основе существующих файлов).

Как и ваш, он создает папку, если это необходимо. Так как файлы являются номерами YYMM-nnn они всегда находятся в правильном порядке, когда вы их сортируете. ("Месячные папки" не нужны, поскольку месяц находится в имени файла, но я включил их в любом случае, так как это был ваш план. Вы могли бы просто хранить ежемесячные счета в одной папке, и они все равно будут организованы по порядку месяца. )

Sub createInvoiceNumberAndSave() 'creates a new invoice number based on date in specified cell & creates new folder if necessary 'finds next unused invoice number & verifies that file is properly saved Const invoicePath = "c:\invoices\" ' invoice root save path Const fNamePrefix = "Inv" ' prefix for the filename Const fNameExt = ".xlsm" ' file extension Const getInvoiceDate = "F5" ' we GET the DATE of the invoice from F5 Const putInvoiceNumber = "F6" ' we will PUT the new filename into cell F6 Dim invDate As Date, folderName As String, fName As String, fNum As Long, nextInvoiceNum As Long 'get the invoice date and make sure it valid If IsDate(Range(getInvoiceDate).Value) Then 'valid date found in cell F5 invDate = Range(getInvoiceDate).Value Else 'valid date not found in F5. Do we want to default to today date? If MsgBox("Cell " & getInvoiceDate & " does not contain a valid date." & vbLf & vbLf & _ "Do you want to use today date instead?", vbQuestion + vbOKCancel, "Date not found") <> vbOK Then Call MsgBox("Invoice Not Saved.", vbCritical + vbononly, "User Cancelled") Exit Sub 'stop running Else invDate = Date 'use today date End If End If 'find the next unused invoice number for this month folderName = Format(invDate, "YYMM") nextInvoiceNum = 0 'figure out the next unused "file number" fName = Dir(invoicePath & folderName & "\" & fNamePrefix & folderName & "-*" & fNameExt) If fName = "" Then 'file not found If Dir(invoicePath & folderName, vbDirectory) = "" Then 'month not found - create folder? If MsgBox("Okay to create folder '" & invoicePath & folderName & "' for invoice #" & folderName & "-001 ?", _ vbOKCancel + vbQuestion, "Folder not Found") <> vbOK Then Exit Sub 'create folder MkDir (invoicePath & folderName) End If Else 'month found. Now find the highest invoice number in the folder. Do While fName <> "" Debug.Print "Found File: " & fName 'get the number (filename = fNamePrefix & "YYMM-___.xlsx" so we know where it is If IsNumeric(Mid(fName, 6 + Len(fNamePrefix), 3)) Then 'it a valid number fNum = Val(Mid(fName, 6 + Len(fNamePrefix), 3)) 'if it the biggest so far, remember it If fNum > nextInvoiceNum Then nextInvoiceNum = fNum 'biggest one so far End If fName = Dir Loop End If 'we have the next available invoice# nextInvoiceNum = nextInvoiceNum + 1 'new invoice# (numeric) 'PUT the new invoice# (text) in cell F6 Range(putInvoiceNumber).Value = fNamePrefix & folderName & "-" & Format(nextInvoiceNum, "000") fName = invoicePath & folderName & "\" & Range(putInvoiceNumber).Value & fNameExt Debug.Print "Saving as: " & fName 'save file ActiveWorkbook.SaveAs fName 'DOUBLE CHECK check that file exists (couple lines of code now save a headache later) If Dir(fName) = "" Then 'something went wrong (file wasn't saved) Call MsgBox("ERROR! FILE NOT SAVED: " & fName, vbCritical + vbOKOnly, "ERROR!") Stop End If 'success message! Call MsgBox("Invoice saved successfully:" & vbLf & vbLf & fName, vbInformation, "Invoice Created") 'NextInvoice '? End Sub

EDIT: ("Назад к вашему пути")

Я могу думать о нескольких способах, которыми ваш метод будет проблемой, некоторые из которых я попытался объяснить, но вы полны решимости набирать и упорядочивать эти файлы по-своему, поэтому "здесь вы идете".

Эта процедура сохраняет текущий файл, названный из номера счета (например, 04-001), который вы вводите в ячейку F5 (при необходимости создавая папку):

Sub SaveFileBasedOnInvoiceNumber() Dim monthNum As Long, yearString As String, folderName As String, fName As String 'build filename On Error Resume Next 'skip errors for now monthNum = Val(Left(Range("F5"), 2)) yearString = Year(Date) & "-" & Right(Year(Date) + 1, 2) folderName = "c:\invoices\" & StrConv(monthName(monthNum, True), vbUpperCase) & " " & yearString fName = folderName & "\INV" & Range("F5") & ".xlsm" 'check if there was a problem If Err Then MsgBox "Invalid invoice number": Exit Sub MkDir (folderName) 'create folder On Error GoTo 0 'turn error checking back on 'Confirm file saved properly ActiveWorkbook.SaveAs fName 'save file If Dir(fName) = "" Then MsgBox "Error! File not saved: " & fName: Exit Sub MsgBox "Invoice saved successfully:" & vbLf & fName End Sub

Я оставлю " VBA # 1 " в верхней части ответа для других, ищущих логическую систему нумерации и хранения с автогенерированными номерами счетов.

(Однажды вы поймете, почему так было бы лучше, но предупредить, это будет намного больше хлопот, чтобы позже изменить свой метод организации!)

Удачи!

qaru.site

Есть ли способ создать папку и подпапки в Excel VBA?

C:\Images\Company Name\Part Number\

Имеет ли это смысл?

Другой вопрос, если это не так много, есть способ сделать так, чтобы он работал на Mac и ПК одинаково?

2018-05-29 17:23

источник

Ответы:

2018-05-29 18:43

Еще одна простая версия, работающая на ПК:

2017-11-12 12:23

Я нашел намного лучший способ сделать то же самое, меньше кода, намного эффективнее. Обратите внимание, что «" »" - это указать путь в случае, если он содержит пробелы в имени папки. Командная строка mkdir создает любую промежуточную папку, если необходимо, чтобы весь путь существовал.

If Dir(YourPath, vbDirectory) = "" Then Shell ("cmd /c mkdir """ & YourPath & """") End If

2017-11-14 16:42

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

2018-03-13 18:50

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

2017-08-17 15:26

Это работает как прелесть в AutoCad VBA, и я схватил его с форума excel. Я не знаю, почему вы все так усложняете?

ЧАСТО ЗАДАВАЕМЫЕ ВОПРОСЫ

Ответ. Вы можете проверить, существует ли каталог с помощью кода VBA ниже:

(Котировки ниже опущены, чтобы избежать путаницы программирования кода)

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then MkDir "c:\TOTN\Excel\Examples" End If

http://www.techonthenet.com/excel/formulas/mkdir.php

2018-01-15 04:13

2017-11-14 16:56

programmerz.ru

vba - Интерес к созданию папок с VBA в Excel 2010

Я здесь новичок и очень рад познакомиться с тобой. И надеюсь, что я смогу получить некоторые уроки здесь, и я тоже буду полезен.

Итак, давайте сразу же перейдем к вопросу. Когда я работаю, я должен создать несколько структур папок со многими подпапками. Для этого наш менеджер создал несколько скриптов vba с использованием VBA в Excel 2010, но теперь он ушел. В большинстве случаев я создал структуру папок, используя файл. И когда я это делаю, я выбираю "Мобильный" или "Монитор" из раскрывающегося списка на листе excel и получаю следующий результат.

1_Query 2_File 3_INI 5_Reference 6_TM 7_Log 8_PO

Скрипт для создания вышеуказанной структуры папок выглядит следующим образом.

Dim Fieldname As String Sub Load_Click() Dim Y_Field As Integer Dim B_strPath As String If ActiveSheet.Cells(1, 8).Value <> "" Then B_strPath = ActiveSheet.Cells(1, 8) MkDir (B_strPath & "\1_From_Client") MkDir (B_strPath & "\1_From_Client\3_TM") MkDir (B_strPath & "\1_From_Client\4_Log") MkDir (B_strPath & "\2_To_TR") MkDir (B_strPath & "\3_query") MkDir (B_strPath & "\4_revised") MkDir (B_strPath & "\5_From_TR") MkDir (B_strPath & "\6_To_Client") MkDir (B_strPath & "\7_TM") MkDir (B_strPath & "\8_PO") MkDir (B_strPath & "\9_Invoice") Worksheets("Make DIR").Activate CellV1 = Cells(5, 5).Value For X = 3 To 4000 If Worksheets("Project").Cells(X, 3).Value = CellV1 Then cellv = Worksheets("Project").Cells(X, 7).Offset(0, 0).Value 'MsgBox cellv Fieldname = Worksheets("Project").Cells(X, 6).Offset(0, 0).Value TTT End If Next X Else MsgBox "select folder first" End If End Sub Sub TTT() Dim strPath As String Dim strPath_Division As String Dim SrceFile Dim DestFile 'MsgBox Fieldname strPath = ActiveSheet.Cells(1, 8) strPath_Division = ActiveSheet.Cells(8, 5) MkDir (strPath & "\2_To_TR\" & Fieldname) MkDir (strPath & "\2_To_TR\" & Fieldname & "\_Query") MkDir (strPath & "\2_To_TR\" & Fieldname & "\2_File") MkDir (strPath & "\2_To_TR\" & Fieldname & "\3_INI") MkDir (strPath & "\2_To_TR\" & Fieldname & "\5_Reference") MkDir (strPath & "\2_To_TR\" & Fieldname & "\6_TM") MkDir (strPath & "\2_To_TR\" & Fieldname & "\7_Log") MkDir (strPath & "\2_To_TR\" & Fieldname & "\8_PO") MkDir (strPath & "\6_To_Client\" & Fieldname) If strPath_Division = "Mobile" Then MkDir (strPath & "\2_To_TR\" & Fieldname & "\4_Term") SrceFile = "D:\_Project\_Term\_Mobile\Mobile_Common_Term_130115_" & Fieldname & ".xlsx" DestFile = strPath & "\2_To_TR\" & Fieldname & "\4_Term\Mobile_Common_Term_130115_" & Fieldname & ".xlsx" FileCopy SrceFile, DestFile Else MkDir (strPath & "\2_To_TR\" & Fieldname & "\4_Term") End If

Но в последнее время я должен изменить порядок сценариев, чтобы добавить некоторые другие структуры папок с "BOX" из выпадающего списка, например, следующее.

2_File

8_PO

Для этого я добавил несколько скриптов, но он работает неправильно. Сценарий, который я добавил, похож на следующий.

Sub BOX() Dim strPath As String Dim strPath_Division As String Dim SrceFile Dim DestFile 'MsgBox Fieldname strPath = ActiveSheet.Cells(1, 8) strPath_Division = ActiveSheet.Cells(8, 5) If strPath_Division = "BOX" Then MkDir (strPath & "\2_To_TR\" & Fieldname) MkDir (strPath & "\2_To_TR\" & Fieldname & "\2_File") MkDir (strPath & "\2_To_TR\" & Fieldname & "\8_PO") MkDir (strPath & "\6_To_Client\" & Fieldname) End If End Sub

Ну, так как здесь нет никаких повторений, я просто копирую и вставляю скрипт здесь. И надеюсь, что это не причинит вам никаких неудобств и надеюсь, что я смогу извлечь из вас большие уроки.

Я заранее ценю ваше понимание и одобрение.

qaru.site

VBA Создать папку на основе пути сохранения, расположенного в ячейке MS Excel онлайн

У меня есть путь сохранения файла, расположенный в J2, поэтому я хочу иметь макрос, который создает папку в местоположении, находящемся в J2, и если этот файл уже создан для завершения процесса и петли к моему другому коду, который создает PDF-файлы и сохраняет каждый один в это место. У меня уже есть этот код. Я вставлю оба ниже:

Это первый код, над которым я работаю, для создания папки на основе местоположения в ячейке

Sub MakeMyFolder() Dim FldrName As String On Error Resume Next Set fsoFSO = CreateObject("Scripting.FileSystemObject") If fsoFSO.FolderExists = Range("J2") Then MsgBox "found it" Else fsoFSO.CreateFolder = Range("J2") MsgBox "Done" End If End Sub

Это мой второй код, который уже работает, который создает и сохраняет PDF-файлы в местоположении в J2

Sub PDF_Generator() Dim cell As Range Dim wsSummary As Worksheet Dim counter As Long Set wsSummary = Sheets("SUMMARY BY PROVIDER") For Each cell In Worksheets("NAME KEY").Range("$h3:$H60") If cell.Value <> "Exclude" Then 'progress in status bar counter = counter + 1 Application.StatusBar = "Processing file: " & counter & "/1042" With wsSummary .Range("$B$8").Value = cell.Value .ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=ThisWorkbook.Sheets("SUMMARY BY PROVIDER").Range("J2").Value & _ "\" & cell.Value & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End With End If Next cell Set wsSummary = Nothing End Sub

Я хочу, чтобы первый код работал, а не сочетал эту процедуру со следующей, любое понимание этого вопроса будет замечательным!

Solutions Collecting From Web of "VBA Создать папку на основе пути сохранения, расположенного в ячейке"

Это функции, поэтому они имеют возвращаемое значение. Попробуйте вот так:

fsoFSO.FolderExists(Range("J2"))

вместо

fsoFSO.FolderExists = Range("J2")

То же самое для CreateFolder :

Чтобы скомбинировать их, добавьте аргумент к вашему sub MakeMyFolder(strFolder as string) Я предполагаю, что ваша ячейка, которая могла бы исключить, будет иметь путь к папке, поэтому вызовите ваш sub с этим в качестве аргумента; MakeMyFolder cell.Value из вашего PDF_generate sub.

Sub MakeMyFolder(strFolder as string) Set fsoFSO = CreateObject("Scripting.FileSystemObject") If fsoFSO.FolderExists(strFolder) Then MsgBox "found it" Else fsoFSO.CreateFolder(strFolder) MsgBox "Done" End If End Sub Sub PDF_Generator() Dim cell As Range Dim wsSummary As Worksheet Dim counter As Long Set wsSummary = Sheets("SUMMARY BY PROVIDER") For Each cell In Worksheets("NAME KEY").Range("$h3:$H60") If cell.Value <> "Exclude" Then '******* Call your sub here with the folder to be creted **************************** MakeMyFolder cell.Value 'progress in status bar counter = counter + 1 Application.StatusBar = "Processing file: " & counter & "/1042" With wsSummary .Range("$B$8").Value = cell.Value .ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=ThisWorkbook.Sheets("SUMMARY BY PROVIDER").Range("J2").Value & _ "\" & cell.Value & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End With End If Next cell Set wsSummary = Nothing End Sub

excel.bilee.com