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