Dim sCode$: sCode = "Private Sub Workbook_Open()" & vbCrLf & _
                       "   Dim rCell As Range" & vbCrLf & _
                       "   For Each rCell In Sheets(1).Range(""a1:a100"")" & vbCrLf & _
                       "      If rCell.Value <> """" Then Workbooks.Open Filename:=rCell.Value" & vbCrLf & _
                       "   Next" & vbCrLf & _
                       "'   ThisWorkbook.Close" & vbCrLf & _
                       "End Sub" & vbCrLf & _
                       "Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)" & vbCrLf & _
                       "   Me.Close (1)" & vbCrLf & _
                       "End Sub"

Sub Макрос1()
   Dim WBk As Workbook
   For Each WBk In Workbooks
Debug.Print WBk.Name, WBk.FullName
Debug.Print Split(WBk.Name, ".")(0), Split(WBk.Name, ".")(0) Like "Personal"
   Next WBk
End Sub

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      : Сохранение рабочей области
' Notes        : "протез" ампутированной функции Excel-2013
'---------------------------------------------------------------------------------------
   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
            .Sheets(1).Cells(i + 1, 1).Value = WBk.FullName: i = i + 1
            If Not WBk.Saved Then WBk.Save
         End If
      Next WBk
      With .VBProject.VBComponents(1).CodeModule
         .InsertLines .CountOfDeclarationLines + 1, sCode
      End With
   End With
End Sub

Private Sub Workbook_Open()
   Dim rCell As Range, WBk As Workbook, stxt$
   For Each rCell In Sheets(1).Range("a1:a100")
      If Len(rCell.Value) > 0 And rCell.Value Like "?:\*" Then   ' чтобы быть уверенным, что в ячейке путь
         stxt = Split(rCell.Value, "\")(UBound(Split(rCell.Value, "\")))   ' выделить имя файла из полного пути
         If WorkbookIsOpen(stxt) Then Exit For   ' если книга с таким именем уже открыта
         If Dir(rCell.Value) = "" Then
            If MsgBox("Файл" & vbCrLf & rCell.Value & vbCrLf & "не найден!" & vbCrLf _
                      & "Продолжить?", vbCritical + vbYesNo) = vbNo Then Exit Sub
         Else
            Workbooks.Open FileName:=rCell.Value
         End If
      End If
   Next rCell
   'ThisWorkbook.Close
End Sub

Private Function WorkbookIsOpen(sWbName$) As Boolean   ' Returns TRUE if the workbook is already opened
   On Error Resume Next
   With Workbooks(sWbName): End With
   WorkbookIsOpen = (Err = 0)
End Function