Страницы: 1
RSS
Создать папку с именем ячейки, в эту папку сохранить открытую книгу
 
Добрый день, разъясните логику кода, не получается добиться цели.
Действия:
    открыть документ, вбить значения, выполнить макрос
Задача макроса:
    создать папку с именем ячейки, в эту папку сохранить открытую книгу и присвоить книге имя этой же ячейки
Макрос нашел на форуме есть код для создания папок, но там файл создается в одной директории с папкой
Код
Sub folder()
On Error Resume Next
For Each oCell In Range([A1], [A65536].End(xlUp))
    If Not IsEmpty(oCell) Then MkDir "C:\Users\Роман\Desktop\шаблон\" & oCell
    ActiveWorkbook.SaveCopyAs filename:=ThisWorkbook.Path & "\" & [A1].Value & ".xls"
Next
End Sub

Изменено: vikttur - 26.06.2021 00:38:49
 
Логика проста, в том что нашли, выполнялось одно действие при выполнении условия и записывалось в одну строку, а вам надо не одно и тут уже нужно использовать конструкцию  If Then End if
Код
Sub folder()
On Error Resume Next
For Each oCell In Range([A1], [A65536].End(xlUp))
    If Not IsEmpty(oCell) Then 
          MkDir "C:\Users\Роман\Desktop\шаблон\" & oCell
          ActiveWorkbook.SaveCopyAs filename:=ThisWorkbook.Path & "\" & [A1].Value & ".xls"
End if
Next
End Sub
По вопросам из тем форума, личку не читаю.
 
К сожалению ваше предложение не помогло, файл по-прежнему создается в том же месте где и папка, а не в самой папке
 
А так попробуйте:
Код
ActiveWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & "\" & [A1].Value & "\" & [A1].Value & ".xls"
 
возникли трудности такого плана: макрос создает папку и фаейл по указанному пути, НО, только в том случае если сам файл (до момента выполнения макроса) находится в том же месте, если я меняю путь  или переношу файл, по указанному пути создается только папка, а книга не сохраняется
Код
Sub folder()
On Error Resume Next
For Each oCell In Range([A1], [A65536].End(xlUp))
    If Not IsEmpty(oCell) Then
    MkDir "C:\Users\Роман\Desktop\Шаблон\" & oCell
    ActiveWorkbook.SaveCopyAs filename:=ThisWorkbook.Path & "\" & [A1].Value & "\" & [A1].Value & ".xls"
End If
Next
End Sub
 
Создавайте директорию в той папке, где находится ThisWorkbook
Код
Dim iPath As String
iPath = ThisWorkbook.Path & "\" & [A1].Value
   'если такой папки нет , то создаем ее
   If Dir(iPath, vbDirectory) = "" Then MkDir iPath
'создаете новую книгу, проделываете с ней манипуляции и сохраняете
ActiveWorkbook.SaveAs iPath  & "\" & [A1].Value & ".xls"
Изменено: Kuzmich - 19.06.2021 19:54:25
 
Как сделать что бы изменения в исходной книге сохранялись ? Если в последней строчке прописываю SaveCopyAs, то созданная книга не отрывается
Код
Dim iPath As String
iPath = ThisWorkbook.Path & "\" & [A1].Value
   'если такой папки нет , то создаем ее
   If Dir(iPath, vbDirectory) = "" Then MkDir iPath
'создаете новую книгу, проделываете с ней манипуляции и сохраняете
ActiveWorkbook.SaveAs iPath  & "\" & [A1].Value & ".xls"
 
Может так:
Тут код

P.S. Для чего вы дублируете код Kuzmich-а? В чем смысл?
Изменено: DANIKOLA - 20.06.2021 17:43:46
 
Роман, написал
Цитата
Как сделать что бы изменения в исходной книге сохранялись ?
Исходная книга - это ThisWorkbook
Код
ThisWorkbook.Close SaveChanges:=True
Страницы: 1
Наверх