Sub Save_WorkSpace_Lite()   ' "протез" ампутированной функции Excel-2013
'---------------------------------------------------------------------------------------
' Procedure    : Save_WorkSpace_Lite
' Author       : Alex_ST
' Post_URL     : http://www.excelworld.ru/forum/2-31951-207738-16-1485342118
' DateTime     : 25.01.2017, 14:01
' Purpose      : Сохранение рабочей области - "протез" ампутированной функции Excel-2013
' Notes        : для автоматического закрытия файла после открытия всех перечисленных в нём книг можно снять комментарий в тексте процедуры в строке "'ThisWorkbook.Close" & vbCrLf & _
'---------------------------------------------------------------------------------------
   Dim sTitle$: sTitle = "Сохранение рабочей области..."
   If MsgBox("Перед сохранением рабочей области" & vbCr & "необходимо сохранить все открытые файлы Excel." & vbCr & _
             "Сохранить файлы и продолжить?", vbYesNo + vbQuestion, sTitle) = vbNo Then Exit Sub
   Dim sCode$: sCode = "Private Sub Workbook_Open()" & vbCrLf & _
                       "   Dim rCell As Range, WBk As Workbook, stxt$" & vbCrLf & _
                       "   For Each rCell In Sheets(1).Range(""a1:a100"")" & vbCrLf & _
                       "      If Len(rCell.Value) > 0 And rCell.Value Like ""?:\*"" Then   ' чтобы быть уверенным, что в ячейке путь" & vbCrLf & _
                       "         stxt = Split(rCell.Value, ""\"")(UBound(Split(rCell.Value, ""\"")))   ' выделить имя файла из полного пути" & vbCrLf & _
                       "         If WorkbookIsOpen(stxt) Then Exit For   ' если книга с таким именем уже открыта" & vbCrLf & _
                       "         If Dir(rCell.Value) = """" Then" & vbCrLf & _
                       "            If MsgBox(""Файл"" & vbCrLf & rCell.Value & vbCrLf & ""не найден!"" & vbCrLf _" & vbCrLf & _
                       "                      & ""Продолжить?"", vbCritical + vbYesNo) = vbNo Then Exit Sub" & vbCrLf & _
                       "         Else" & vbCrLf & _
                       "            Workbooks.Open FileName:=rCell.Value" & vbCrLf & _
                       "         End If" & vbCrLf & _
                       "      End If" & vbCrLf & _
                       "   Next rCell" & vbCrLf & _
                       "   'ThisWorkbook.Close" & vbCrLf & _
                       "End Sub" & vbCrLf & vbCrLf & _
                       "Private Function WorkbookIsOpen(sWbName$) As Boolean   ' Returns TRUE if the workbook is already opened" & vbCrLf & _
                       "   On Error Resume Next" & vbCrLf & _
                       "   With Workbooks(sWbName): End With" & vbCrLf & _
                       "   WorkbookIsOpen = (Err = 0)" & vbCrLf & _
                       "End Function" ' текст кода процедур, прописываемых в создаваемую книгу рабочей области
   Dim WBk As Workbook, i%
   Dim WSWBk As Workbook: Set WSWBk = Application.Workbooks.Add ' создать новую книгу
   With WSWBk
      For Each WBk In Workbooks ' цикл по всем открытым книгам
         If Not LCase(Split(WBk.Name, ".")(0)) = "personal" And WBk.Name <> .Name Then ' если это не PERSONAL и не созданная новая книга, то:
            If Not WBk.Saved Then WBk.Save ' сохранить книгу
            .Sheets(1).Cells(i + 1, 1).Value = WBk.FullName: i = i + 1 ' на первый лист записать полный путь к книге
         End If
      Next WBk
      With .VBProject.VBComponents(1).CodeModule
         .InsertLines .CountOfDeclarationLines + 1, sCode ' добавить процедуры в модуль ЭтаКнига созданной книги рабочей области
      End With
   End With
End Sub