При закрытии имя файла с разных ячеек

[doober]

Лови,думаю разберешься

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Boolean

Function FolderCreate(ByVal path As String) As Boolean
    On Error GoTo ErrFailed
    FolderCreate = MakeSureDirectoryPathExists(path)
    Exit Function
ErrFailed:
    FolderCreate = False
End Function

Function FolderExists(ByVal path As String) As Boolean
    FolderExists = False
    Set fso = CreateObject("Scripting.FileSystemObject")
  
    If fso.FolderExists(path) Then
        FolderExists = True
    Else
        FolderExists = FolderCreate(path)
    End If
     Set fso = Nothing
End Function

Function Путь(Папка As String)
 Путь = Папка & "\" & Format(Date, "MMMM") & "\"
FolderExists Путь
End Function

Sub Проверка()
Dim Имя As String, Папка As String
Имя = "35 18.02.14 Шаповалов"
Папка = "D:\MMM"
Имяфайла = Путь(Папка) & Имя
End Sub

[valerij]

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

Лови,думаю разберешься

Спасибо, попробую...
А вот моё решение, вернее staniiislav + я

Private Sub Workbook_Open()
    Sheets("ПУТЁВКА").Select
           If [h6] = "" Then [h6] = Date 'вставляем дату
    [a5].Activate 
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim msg$, iFileName$, iPath$, iPathSeparator$, iSaveName$, месяц$
        месяц = MonthName(Month(Now))
        MyPath = "G:\Путёвки\2014\" & месяц & ""
Application.EnableEvents = False
On Error Resume Next
msg = "Сохранить изменения в файле '" & ActiveWorkbook.Name & "'?"
    Select Case MsgBox(msg, vbExclamation + vbYesNoCancel)
        Case vbYes
            iFileName = ActiveWorkbook.Name
            iPath = MyPath 'ActiveWorkbook.Path '''
            iPathSeparator = Application.PathSeparator '"\"
            iFileNameSplit = Split(Sheets("ПУТЁВКА").Range("M11").Value, " ")
            iSaveName = Sheets("ПУТЁВКА").Range("G6") & " " & Sheets("ПУТЁВКА").Range("H6") & " " & iFileNameSplit(0) & " " & ".xlsm"
            ActiveWorkbook.SaveCopyAs _
            Filename:=iPath & iPathSeparator & iSaveName
            ThisWorkbook.Save
        Case vbNo
            ThisWorkbook.Saved = True   'не сохраняя книгу, показывает приложению, что она сохранена!!!
        Case vbCancel
            Cancel = True
    End Select
End Sub

[IgorGO]

Валера, ну подарили тебе очередной макрос... поздравляю!!!

если мне подарят трактор, вспахать огород у мамы, не вспашу я, я не умею управлять трактором, да еще с навесным оборудованием, скорее всего поломаю заборы, а то еще и дом зацеплю

ой, тревожно мне... за акваторию Азова в районе Мариуполя.

[valerij]

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

Валера, ну подарили тебе очередной макрос... поздравляю!!!

если мне подарят трактор, вспахать огород у мамы, не вспашу я, я не умею управлять трактором, да еще с навесным оборудованием, скорее всего поломаю заборы, а то еще и дом зацеплю

ой, тревожно мне... за акваторию Азова в районе Мариуполя.

Игорь, чё за бред несёшь?
Майдан вплывает?
Поражён, не ожидал.

Удачи.

[maksim_serg]

стало вот интересно:

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Boolean

Перевод: (автоматический, с помощью Microsoft Translate API)
IMAGEHLP.dll представляет собой модуль, принадлежащих к рекламной программы. Этот модуль отслеживает ваши привычки просмотра и распространяет их обратно на серверы автора для анализа. Это также заставляет всплывающие рекламные окна. Этот процесс представляет собой угрозу безопасности и должны быть удалены из вашей системы.

[staniiislav]

Создайте модель и в него поместите:

Option Explicit

Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
                                     (ByVal hwnd As Long, ByVal pszPath As String, _
                                      ByVal psa As Any) As Long
                                      
Sub Macros_Close()
Dim msg$, iFileNameSplit, iPath_1$, iPath_2$, iPathSeparator$, iSaveName$, iYear$, iMonth$, Cancel As Boolean, Wb As Workbook
On Error Resume Next
Set Wb = ThisWorkbook
iFileNameSplit = Split(Sheets("ПУТЁВКА").Range("M11").Value, " ")
iSaveName = Sheets("ПУТЁВКА").Range("G6") & " " & Sheets("ПУТЁВКА").Range("H6") & " " & iFileNameSplit(0) & ".xlsx"

msg = "Сохранить файл '" & iSaveName & "'?"
    Select Case MsgBox(msg, vbExclamation + vbYesNoCancel)
        Case vbYes
            iYear = Format(Now, "yyyy"): iMonth = Format(Now, "mmmm")
            iPath_1 = Wb.Path '''
            iPath_2 = iPath_1 & "\" & iYear & "\" & iMonth
            CreateFolderWithSubfolders iPath_2
            
            
            iPathSeparator = Application.PathSeparator '"\"
            
            Application.DisplayAlerts = False
            Wb.SaveAs _
            Filename:=iPath_2 & iPathSeparator & iSaveName, FileFormat:=51
            Application.DisplayAlerts = False
            Wb.Save
        Case vbNo
            ThisWorkbook.Saved = True   'не сохраняя книгу, показывает приложению, что она сохранена!!!
        Case vbCancel
            Cancel = True
    End Select
End Sub

'Макрос взяот от сюда:
'http://excelvba.ru/code/MkDir
Sub CreateFolderWithSubfolders(ByVal ПутьСоздаваемойПапки$)
    ' функция получает в качестве параметра путь к папке
   ' если такой папки ещё нет - она создаётся
   ' может создаваться сразу несколько подпапок
   If Len(Dir(ПутьСоздаваемойПапки$, vbDirectory)) = 0 Then    ' если папка отсутствует
       SHCreateDirectoryEx Application.hwnd, ПутьСоздаваемойПапки$, ByVal 0&    ' создаём путь
   End If
End Sub

В модуле книге:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call Macros_Close
End Sub

[valerij]

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

Создайте модель

staniiislav!
Модель или модуль??
Если модель, то это точно не для меня.

А если модуль, то попробовал, понравилось, но у меня - это разово получилось.
Т. к. все макросы исчезли.
Странно, почему так произошло(тоже понял почему, так ), а потом всё ОК!!

У меня в макросе возникла проблема с датой, т. е. как выше - не пойдёт.
Получается, что есть шаблон - имя файла "ПУТЁВКИ" и созданные файлы при закрытии, распиханные по месяцам.
файл "ПУТЁВКИ" может находится где угодно, а остальные строго по указанному пути в макросе.
Так вот дата при открытии(If [h6] = "" Then [h6] = Date) подходит к вновь созданным, но не к шаблону, т. е. если открыть их в любое время дата сохранится.
Поэтому я в шаблоне в конце закрытия удаляю дату и № путёвки.

Private Sub Workbook_Open()
    Sheets("ПУТЁВКА").Select
        If [h6] = "" Then [h6] = Date
    [a5].Activate
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim msg$, iFileName$, iPath$, iPathSeparator$, iSaveName$, месяц$
        месяц = MonthName(Month(Now))
        MyPath = "G:\Путёвки\2014\" & месяц & ""
Application.EnableEvents = False
Application.ScreenUpdating = False
On Error Resume Next
            iFileName = ActiveWorkbook.Name
            iPath = MyPath 'ActiveWorkbook.Path '''
            iPathSeparator = Application.PathSeparator '"\"
            iFileNameSplit = Split(Sheets("ПУТЁВКА").Range("M11").Value, " ")
            iSaveName = Sheets("ПУТЁВКА").Range("G6") & " " & Sheets("ПУТЁВКА").Range("H6") & " " & iFileNameSplit(0) & " " & ".xlsm"
            ActiveWorkbook.SaveCopyAs _
            Filename:=iPath & iPathSeparator & iSaveName
            ThisWorkbook.Save
    Sheets("ПУТЁВКА").[g6:h6] = ""
    Application.EnableEvents = True
    Application.ScreenUpdating = False
End Sub

Но, ненаю, чего -то мне не очень нравится моё произведение.
Теперь понял, почему.

Всё разобрался, всё получилось, только добавил при открытии дату.

Private Sub Workbook_Open()
    Sheets("ПУТЁВКА").Select
        [h6] = Date
    [a5].Activate
End Sub

staniiislav!!!!
Спасибо, всё супер.
---------------
| ^^пиво^^ \\|""\\_,_
|___________||___|__|)
(@)(@)""*|(@)(@)**(@)

[doober]

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

стало вот интересно:

Предохраняйтесь при загрузке винды,она опасна.
magehlp.dll является DLL-файлом, который отвечает за компонент Windows NT Image Helper в ОС Windows системы