Код VBA для создания папок и подпапок при ссылке на диапазон ячеек от столбца B до D?
У меня есть 4 столбца данных в Excel, которые я пытаюсь преобразовать в список папок и подпапок. Столбец B будет первым списком основных папок, а каждая запись столбца C будет вложенной папкой и глубже в подпапку столбца D в соответствующей папке из столбца B.
Колонка А состоит из имен файлов .pdf, хранящихся в исходных местах назначения, которые необходимо перенести в последнюю подпапку целевого места назначения.
Исходный и целевой каталог:
- Источник:
C:\Users\Manzurfa\Desktop\Macro Project\Carlo Project\Order Confirmations - Цель:
C:\Users\Manzurfa\Desktop\Macros
Примечание. Исходный каталог содержит все файлы .pdf. После создания всех папок и подпапок мне нужно, чтобы файлы .pdf были перенесены в последнюю подпапку, упомянутую в целевом каталоге.
A B C D
Sales doc. Sales Rep Customer Name Sold to
536460575 Carolyn Coulter A STEP AHEAD FOOTWEAR INC 108845
536460718 Carolyn Coulter A STEP AHEAD FOOTWEAR INC 108845
536810226 Carolyn Coulter A STEP AHEAD FOOTWEAR INC 108845
538391188 Carolyn Coulter A STEP AHEAD FOOTWEAR INC 108845
536281822 Carolyn Coulter ALPHA COMFORT SHOES INC 157808
Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 2 To maxCols
r = 2
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub
Любая помощь в будет безмерно оценена!
Ответы 1
Непроверенный:
Sub Tester()
Const SRC_FOLDER = "C:\Users\Manzurfa\Desktop\Macro Project\Carlo Project\Order Confirmations\"
Const DEST_FOLDER = "C:\Users\Manzurfa\Desktop\Macros"
Dim Rng As Range, fPath, fName
Dim maxRows As Long, maxCols As Long, r As Long, c As Long
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
'assuming the first row in ther selection is the headers...
' otherwise, start at 1
For r = 2 To maxRows
fPath = DEST_FOLDER '<<set starting point
For c = 2 To maxCols
fPath = fPath & "\" & Rng.Cells(r, c) '<<build next level
If Len(Dir(fPath, vbDirectory)) = 0 Then MkDir fPath
Next c
'create file name
fName = Right("0000000000" & Rng.Cells(r, 1).Value, 10) & ".pdf"
'copy to fpath
FileCopy SRC_FOLDER & fName, fPath & "\" & fName
Next r
End Sub
Что делает это делает?
@ Тим Уильямс, когда я нажимаю кнопку F8, чтобы проверить макрос, он продолжает циклически повторяться сверху вниз, без папок или подпапок в папках назначения. Так же не работает "кнопка воспроизведения". Например, когда я пытаюсь запустить макрос, он ничего не делает.
И вы выбираете полный набор данных перед запуском?
Ой! Я не выбрал весь диапазон данных перед запуском кода. Я попытался сделать это, и он вернул сообщение об ошибке: ошибка времени выполнения «53»: файл не найден. Выделенная строка с ошибкой: FileCopy SRC_FOLDER & fName, fPath & "\" & fName"
Я изменил исходный путь и заметил, что теперь есть ошибка со строкой ниже. Если Len(Dir(fPath, vbDirectory)) = 0 Тогда MkDir fPath
Я рад помочь вам заставить это работать, но вам нужно будет быть немного более явным, чем «есть ошибка» - какое сообщение об ошибке вы получаете? Если вы добавите Debug.Print fPath непосредственно перед строкой с ошибкой, каков будет вывод (он появится в непосредственной панели VBeditor — Ctrl + G, чтобы показать, если он еще не виден)?
Это сработало блестяще. У меня было имя файла с "/", поэтому он выдал ошибку. Ты восхитителен. Большое спасибо за то, что помогли мне с этим.
Приятно слышать, что у тебя все получилось
спасибо @ Тим Уильямс. Я ценю, что вы сели за то, чтобы написать решение моего вопроса, несмотря на мое непонимание VBA. Я протестировал его, но, похоже, он не создает папки/подпапки в целевом месте назначения. Не могли бы вы предложить мне изменить папку назначения?