Генератор папок с файлами

Пользователь

Сообщений: 11 Регистрация: 10.12.2015

23.04.2016 19:24:43

Всем доброго времени, прошу помощи с заданием.
"Генератор папок с книгами Excel по информации из БД проектов"
Как понимаю изначально нужен файл где будет небольшая таблица с названием проектов и именами необходимых файлов. Собственно с ним проблем нет, но вот как на vba создать генератор папок и файлов, который будет брать имена папок из столбца Проект и имена файлов из соседних, пример прикреплю.
Буду безмерно благодарная за помощь или хотя бы если подскажете с чего начать.

Прикрепленные файлы

проекты.xlsx (9.2 КБ)

Пытливый

Пользователь

Сообщений: 4725 Регистрация: 22.12.2012

23.04.2016 19:49:13

Здравствуйте.
Что должен делать этот "генератор"?
Если надо сохранить файл, используя в качестве имени содержимое ячейки, то таких примеров на форуме множество - можно поиском порыть.
Ну, или папку создать/проверить, существует ли с именем, заданным в ячейке - тоже было тут не один раз.

Кому решение нужно - тот пример и рисует.

Kuzmich

Пользователь

Сообщений: 8189 Регистрация: 21.12.2012

23.04.2016 19:58:02

Код

Sub Generator()
Dim i As Integer
Dim iLastRow As Integer
Dim iPath As String
Dim Papka As String
Dim iFileName As String
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 3 To iLastRow
    Papka = Cells(i, 1)
    iPath = ThisWorkbook.Path & "\" & Papka & "\"
      If Dir(iPath, vbDirectory) = "" Then MkDir iPath
      iFileName = Cells(i, 2)
      If Dir(iPath & iFileName) = "" Then
        Workbooks.Add(xlWBATWorksheet).Worksheets(1).Name = Cells(i, 3)
        ActiveWorkbook.SaveAs FileName:=iPath & iFileName
        ActiveWorkbook.Close
      End If
  Next
End Sub

Moira Пользователь Сообщений: 11 Регистрация: 10.12.2015	#4 23.04.2016 20:28:53 Пытливый,почти, собственно ниже идеальный вариант Kuzmich, огромнейшее спасибо, 100 + в карму.

viktor.petryuk Пользователь Сообщений: 11 Регистрация: 15.12.2016	#5 31.10.2017 18:27:09 Еще вариант с созданием папок (3 уровня) по столбцам 1,2,3 и перемещение в них файлов погиперссылкам из 4 столбца (Спасибо Чупееву Максиму))): КОД Sub Creator() 'определяем корневой каталог, куда будут сыпаться все наши папки. Set fs = CreateObject("Scripting.FileSystemObject") 'узнать имя и путь открываемого файла fname = Application.GetOpenFilename 'узнать только имя файла s = fs.GetFileName(fname) 'убрать из полного пути файла его название, оставив только путь к папке. ss = Left(fname, Len(fname) - Len(s)) 'делаем цикл, который прекращает работать при первой же пустой ячейке в первом столбце Dim i As Long i = 1 Do While Worksheets("Лист1").Cells(i, 1) <> Empty 'на ошибке продолжаем макрос On Error Resume Next 'создаем папку из первого столбца fokinway1 = ss & "\" & Worksheets("Лист1").Cells(i, 1).Value & "\" MkDir fokinway1 'создаем папку из второго столбца в первой папке fokinway2 = ss & "\" & Worksheets("Лист1").Cells(i, 1).Value & "\" & Worksheets("Лист1").Cells(i, 2).Value & "\" MkDir fokinway2 'создаем папку из третьего столбца во второй папке fokinway3 = ss & "\" & Worksheets("Лист1").Cells(i, 1).Value & "\" & Worksheets("Лист1").Cells(i, 2).Value & "\" & Worksheets("Лист1").Cells(i, 3).Value & "\" MkDir fokinway3 'при желании можно продолжить кол-во папок... 'узнаем имя файла из четвертого столбца (без пути) fokinfile = Worksheets("Лист1").Cells(i, 4) fokinfilename = fs.GetFileName(fokinfile) Dim sFileName As String, sNewFileName As String 'старое название файла и путь - в столбце 4 sFileName = Worksheets("Лист1").Cells(i, 4) 'новое название файла и путь - путь последней созданной папки+название файла sNewFileName = fokinway3 & fokinfilename Name sFileName As sNewFileName 'следующая строка i = i + 1 'вернуться к началу цикла Loop End Изменено: viktor.petryuk - 03.11.2017 13:31:33 (Решение)

Читают тему