Sub CopyArrSheets()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ReDim arrSh(1)
arrSh(0) = "Общий отчет"
N = 1
For I = 4 To Cells(4, Columns.Count).End(xlToLeft).Column
    If Cells(4, I) <> Empty Then
        ReDim Preserve arrSh(N)
        arrSh(N) = Cells(4, I).Text
        N = N + 1
    End If
Next
Worksheets(arrSh).Copy
With ActiveWorkbook
    With Worksheets("Общий отчет")
        .UsedRange.Value = .UsedRange.Value
        .DrawingObjects.Delete
    End With
    .SaveAs Filename:=ThisWorkbook.Path & "\" & "Отчет.xls", FileFormat:=xlExcel8
    .Close True
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub test()
Dim coll As New Collection, ikey
Dim arr(), ipath$
Dim book As Workbook, ibook As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set book = ThisWorkbook
ipath = book.Path & "\"
With Sheets("Общий отчет")
    arr = .Range(.[d4], .[d4].End(xlToRight)).Value
End With
For Each ikey In arr
    If Not IsEmpty(ikey) Then coll.Add ikey, CStr(ikey)
Next ikey
With book
    .Sheets("Общий отчет").Copy
    Set ibook = ActiveWorkbook
    ibook.SaveAs Filename:=ipath & "Test.xlsx"
    For Each ikey In coll
        .Sheets(ikey).Copy after:=ibook.Sheets(ibook.Sheets.Count)
    Next ikey
    For Each ikey In ibook.Sheets(1).Shapes
        ikey.Delete
    Next ikey
    ibook.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub Макрос3()
Dim i&, k&, ar(1 To 4)
  For i = Worksheets.Count - 3 To Worksheets.Count
    k = k + 1
    ar(k) = i
  Next
  Worksheets(ar).Copy
  ActiveWorkbook.BreakLink Name:=ThisWorkbook.FullName, Type:=xlExcelLinks
End Sub