Добрый день, разъясните логику кода, не получается добиться цели. Действия: открыть документ, вбить значения, выполнить макрос Задача макроса: создать папку с именем ячейки, в эту папку сохранить открытую книгу и присвоить книге имя этой же ячейки Макрос нашел на форуме есть код для создания папок, но там файл создается в одной директории с папкой
Код
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
Логика проста, в том что нашли, выполнялось одно действие при выполнении условия и записывалось в одну строку, а вам надо не одно и тут уже нужно использовать конструкцию 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
возникли трудности такого плана: макрос создает папку и фаейл по указанному пути, НО, только в том случае если сам файл (до момента выполнения макроса) находится в том же месте, если я меняю путь или переношу файл, по указанному пути создается только папка, а книга не сохраняется
Код
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"
Как сделать что бы изменения в исходной книге сохранялись ? Если в последней строчке прописываю SaveCopyAs, то созданная книга не отрывается
Код
Dim iPath As String
iPath = ThisWorkbook.Path & "\" & [A1].Value
'если такой папки нет , то создаем ее
If Dir(iPath, vbDirectory) = "" Then MkDir iPath
'создаете новую книгу, проделываете с ней манипуляции и сохраняете
ActiveWorkbook.SaveAs iPath & "\" & [A1].Value & ".xls"
Sub OpenAndSave1()
Dim folderPath As String, filePath As String
'если ячейка A1 пуста, то выход из процедуры
If IsEmpty([A1]) Then Exit Sub
folderPath = ThisWorkbook.Path & "\" & [A1].Value
filePath = folderPath & "\" & [A1].Value & ".xls"
'если такой папки нет, то создаем её
If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath
'если такой файл уже существует, то открываем его
If Dir(filePath) <> "" Then
Workbooks.Open filePath
'Здесь делаете с книгой, что вам нужно
'Cохраняем книгу или закрываем с сохранением ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.Save
Else
'иначе активную книгу сохраняем как копию
ActiveWorkbook.SaveCopyAs filePath
End If
End Sub
Новый код - модификация кода из №6, см., в файле BookMacro2.xls
Код
Sub folder2()
Dim folderPath As String, filePath As String, oCell As Range
'Диалог выбора папки
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.ButtonName = "Выбрать эту папку"
If .Show = -1 Then
folderPath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
For Each oCell In Range([A1], [A65536].End(xlUp))
If Not IsEmpty(oCell) Then
If Dir(folderPath & oCell, vbDirectory) = "" Then
MkDir folderPath & oCell
End If
'имя файла
filePath = folderPath & oCell.Value & "\" & oCell.Value & ".xls"
ActiveWorkbook.SaveCopyAs Filename:=filePath
End If
Next oCell
End Sub
P.S. Для чего вы дублируете код Kuzmich-а? В чем смысл?