Sub Сохранить_в_файлы()
On Error Resume Next
Application.ScreenUpdating = False
' Сохранение нужных листов для отчетов
Dim NewWb As Workbook
'Заносим имя текущей книги в переменную
n = ActiveWorkbook.Name
'Создаем новую книгу с 1-м пустым листом
Set NewWb = Workbooks.Add(1)
'Активируем старую книгу
Windows(n).Activate
'Указываем массивом листы, которые хотим скопировать
Sheets(Array("по дням", "накопительно", "ТОП", "ABC", "PL")).Copy Before:=Workbooks(NewWb.Name).Sheets(1)
' Отключаем любые окна предупреждений
Application.DisplayAlerts = False
' Удаляем существовавший пустой лист
Sheets("Лист1").Delete
Sheets("накопительно").Activate
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("A1").Select
' Сохраняем книгу по данным первых ячеек, с нужным именем
s = Mid(n, InStrRev(n, "\") + 1, InStrRev(n, ".") - InStrRev(n, "\") - 1)
Call Создание_папки ' создаем нужные папки
Call Связи 'разрываем все связи
ActiveWorkbook.SaveAs FileName:=aa & s & " по " & DateValue(Now) - 1 & " включительно.xlsx"
ActiveWorkbook.SaveAs FileName:=dd & s & " по " & DateValue(Now) - 1 & " включительно.xlsx"
'Закрываем книгу
ActiveWorkbook.Close
'Сбрасываем выделение
'Windows(n).Worksheets(2).Range("A2").Select
Workbooks(n).Save
'Создаем агрегатный файл
Set NewWb = Workbooks.Add(1)
ActiveWorkbook.SaveAs FileName:=dd & "Для рассылки на " & DateValue(Now) & ".xlsx"
ActiveWorkbook.Close
Windows(n).Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub Обработка_цикл()
Dim whr As Worksheet
'On Error Resume Next
'Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Application.CalculateBeforeSave = False
n = ActiveWorkbook.Name
  MyPath = MyPath & ActiveWorkbook.Path & IIf(Right(MyPath, 1) = Application.PathSeparator, "", Application.PathSeparator)
MyFileName = Dir(MyPath & "Отчет*.xls*")
    Do Until MyFileName = ""
                MyFullName = MyPath & MyFileName
            Workbooks.Open FileName:=MyFullName, UpdateLinks:=0
            s = ActiveWorkbook.Name
Call Общий_обработчик
Call Сохранить_в_файлы
        MyFileName = Dir
   Loop
    End Sub