макрос на экспорт данных

[eol]

Добрый день, нужна помощь в создании макроса.
Задача следующая:
есть книга, по нажатию некой кнопки происходит автоматическое сохранение книги в папку "расположение файла/создается папка с названием из ячейки А1 со следующим названием файла:
[ячейка А2] [дата] [автор].xls

Например:
в ячейке а1 у нас "проект 1"
в ячпйке а2 "Калькуляция на изделие 1"
при сохранении будет создана папка проект 1, в ней файл "Калькуляция на изделие 1 от 10.10.12 автор Ivanov.xls"

Желательно защитить сам исходный файл от изменения, я думаю его есть смысл сделать шаблоном?

[VictorM]

есть книга

Нету!
И никто ее не будет создавать.
Если есть, давайте пример файла с Вашими наработками.

[eol]

Сообщение от VictorM

Нету!
И никто ее не будет создавать.
Если есть, давайте пример файла с Вашими наработками.

Добавил пример.

замучался, получается пока не чоень

[Shkoda]

Сообщение от eol

замучался, получается пока не чоень

А что именно не получается? могу помочь с созданием папки, файла с названием [ячейка А2] [дата] .xls а вот как определить автора увы не знаю.

[doober]

Желательно защитить сам исходный файл от изменения,

И это реализовано.
Код в отдельном файле

[eol]

Сообщение от doober

И это реализовано.
Код в отдельном файле

Уважаемый Сергей, большое спасибо!
К сожалению защищенный файл не работает, там не нажимается кнопка. Создал новый используя cls.
Также папка почему-то не создается (создается папка "0", если я меняю Temp_path = ThisWorkbook.Path & "\" & [a1], все начинает работать).
В процессе я также понял, что неправилньо изначально оценил задачу. Получается что при повторном нажатии путь будет attachment\0\0\0\0 и тд, а мне нужно, чтобы исходный файл оставался на месте. Можно ли сделать так, чтобы создавалась копия книги и сохранялась в папака расположения файла/название папки из А2/ и куча папок бы не плодилась, при этом мы бы оставались работать в исходном файле.

Также интересен механизм защиты, который вы реализовали. Я покопался, возможно он взят отсюда?
1. Save the Excel workbook (.xls) file into an add-in (File > SaveAs.....)
2. After you have the saved add-in (.xla), close the Excel workbook (.xls)
3. Double click on the add-in to open it
4. Press Alt+F11 to access the add-in's vba project
5. Lock the vba-project with a password
6. Double-click on the "ThisWorkbook" code module
7. Press F4 to open the Properties window
8. Change the "IsAddin" status to FALSE
9. Return to Excel by Pressing Alt+Q (or close the vbe window)
10. Go to Tools > Share Workbook
11. When the dialogue appears, check the box for: (Allow changes by.....)
12. Press OK to close the Dialogue
13. When prompted to save, Press OK
14. Press Ok to accept that "macros cannot be accessed"
15. You should feel giddy at this point because you just realized what you have
been missing right under your nose
16. Verify that the [SHARED] appears in the application title bar
17. Now save the workbook again as an Add-in (File > SaveAs...) overwriting the
previous one
18. Close this Excel workbook without saving the changes (you don't need it)
19. Test out your newly saved add-in (open it, access the vbe, try to expand
the project window, you should get the new message "Project is Unviewable"
20. Your done

[eol]

В целом все более менее понятно, за исключением назначения функции typ_folder.

Private Sub CommandButton1_Click()

Dim Author As String, Filename, Folder As String
Author = ThisWorkbook.UserStatus(1, 1)
ThisWorkbook.Author = Author

Filename = [A2] & Date & " àâòîð " & Author & ".xls"

Folder = Typ_Folder([a1])
Temp_path = ThisWorkbook.Path & "\" & [a1]

Set oFS = CreateObject("Scripting.FileSystemO bject")

If Not oFS.FolderExists(Temp_path) Then
oFS.CreateFolder (Temp_path)
End If

ThisWorkbook.SaveAs Filename:= _
Temp_path & "\" & Filename, FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False

End Sub
Private Function Typ_Folder(ByVal S) As String
Dim n As Integer, m As Integer, sl As String
S = Trim(S)
bRes = False
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = False
RegExp.IgnoreCase = True
RegExp.Pattern = "(\d{1,})"
bRes = RegExp.test(S)
If bRes Then
For Each cMatches In RegExp.Execute(S)
Typ_Folder = cMatches.Value
Exit Function
Next
End If
Typ_Folder = "0"
End Function

[doober]

Она получает имя папки для сохранения
по номеру проекта.Если номер не определен,тогда 0

If bRes Then
 For Each cMatches In RegExp.Execute(S)
 Typ_Folder = cMatches.Value
 Exit Function
 Next
 End If
 Typ_Folder = "0"
 End Function

Замените на

If bRes Then
 For Each cMatches In RegExp.Execute(S)
 Typ_Folder = "Проект " & cMatches.Value
 Exit Function
 Next
 End If
 Typ_Folder = "Проект " &  "0"
 End Function