Private Sub Application_NewMail()
Dim Item As Outlook.MailItem ()
Dim xl As Object
       If Item.Subject = "Запуск макроса 1" Then
           Item.MarkComplete
            Set xl = CreateObject("Excel.Application")
            xl.Workbooks.Open ("C:\Users\Desktop\Работа\Макрос1.xlsm")
            xl.Run "'Макрос1.xlsm!'Test"
            xl.Quit
         Set xl = Nothing
       End If

End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim Item As Outlook.MailItem
Dim xl As Object
       If Item.Subject = "Запуск макроса 1" Then
           Item.MarkComplete
           Set xl = CreateObject("Excel.Application")
           xl.Workbooks.Open ("C:\Users\Users\Desktop\Работа\Макрос1.xlsm")
            xl.Run "'Макрос1.xlsm!'Test"
            xl.Quit
         Set xl = Nothing
       End If

End Sub

Sub Обновление_запросов_в_файлах_папок()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Dim lLastRow As Long
On Error Resume Next
   lLastRow = Worksheets("Папки").Cells(Rows.Count, 1).End(xlUp).Row
    Set TW = ThisWorkbook 'объявляем короткую объект-переменную, нужна будет для передачи в процедуру RefreshQueries
    For i = 2 To lLastRow
        WORK_FOLDER = TW.Sheets("Папки").Range("A" & i).Value
        If Not IsEmpty(WORK_FOLDER) Then 'если в ячейке не пустота, то
            With CreateObject("Scripting.FileSystemObject") 'используем объект, для работы с папками и файлами(позднее связывание)
                For Each File In .GetFolder(WORK_FOLDER).Files 'перечисляем все файлы в указанной папке
                    If InStr(File, ".xls") > 0 Then 'проверяем чтобы в имени файла имелись символы .xls(т.е. это могут быть .xls, xlsm, xlsx, xlsb), эту проверку можно переделать, т.к. если будет файл file.xls.doc, то поймаем ошибку
                        .CopyFile File, WORK_FOLDER & "\Архив\" & File.Name & " " & Format(Now() - 1, "DD/MM/YYYY") & ".xlsm"
                        RefreshQueries TW, File, i: DoEvents 'передаем процедуре RefreshQueries параметры - объект нашей книги, полное имя файла и номер строки: после окончания процедуры запускаем DoEvents
                    End If
                Next File
            End With
        End If
        TW.Sheets("Папки").Range("B" & i).Value = DateValue(Now) & " / " & TimeValue(Now): DoEvents
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
End Sub

Private Sub RefreshQueries(ByVal TW As Workbook, ByVal File As String, ByVal Row As Integer)
                BValue = TW.Sheets("Папки").Range("B" & Row).Value
                CValue = TW.Sheets("Ошибки").Range("A2").Value
                Set WO = Workbooks.Open(File)
                FName = WO.Name
                If WO.ReadOnly = False Then
                    On Error Resume Next
                    For Each oc In WO.Connections
                      oc.OLEDBConnection.BackgroundQuery = False 'отключаем обновление в фоне
                                        oc.Refresh 'обновляем
                                        oc.OLEDBConnection.BackgroundQuery = True 'включаем обновление в фоне
                            If Err.Number <> 0 Then
                                'TW.Sheets("Папки").Range("C" & Row).Value = IIf(Len(CValue) = 0, FName & ". " & "Сбой запросов PQ. " & oc.Name, CValue & vbCrLf & FName & ". " & "Сбой запросов PQ. " & oc.Name): DoEvents
                                TW.Sheets("Ошибки").Range("A2").Value = IIf(Len(CValue) = 0, FName & ". " & "Сбой запросов PQ. " & oc.Name, CValue & vbCrLf & FName & ". " & "Сбой запросов PQ. " & oc.Name): DoEvents
                                Err.Clear
                            End If
                     Next oc
                TW.Sheets("Папки").Range("B" & Row).Value = DateValue(Now) & " / " & TimeValue(Now)
                WO.Close True
                Set WO = Nothing
                Else
                TW.Sheets("Ошибки").Range("A2").Value = IIf(Len(CValue) = 0, FName & ". " & "Был недоступен для редактирования", CValue & vbCrLf & FName & ". " & "Был недоступен для редактирования"): DoEvents
                Err.Clear
                WO.Close False
                Set WO = Nothing
                End If
End Sub

    Cells.Replace What:="СУММЕСЛИМН(#ССЫЛКА!;#ССЫЛКА!", Replacement:= _
        "СУММЕСЛИМН(ФОТ_мой[Сумма];ФОТ_мой[критерий]", LookAt:=xlPart, SearchOrder _
        :=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:= _
        False, FormulaVersion:=xlReplaceFormula2

rivate Sub RefreshQueries(ByVal TW As Workbook, ByVal File As String, ByVal Row As Integer)
                Application.AskToUpdateLinks = False
                Set WO = Workbooks.Open(File) 'открываем книгу по полному имени файла и сразу передаем в объект-переменную WO
                On Error GoTo ErrorHandler 'включаем обработчик ошибок, с перебросом к метке в случае ошибки
                For Each oc In WO.Connections 'перебираем все подключения в книге
                    oc.OLEDBConnection.BackgroundQuery = False 'отключаем обновление в фоне
                    oc.Refresh 'обновляем
                    oc.OLEDBConnection.BackgroundQuery = True 'включаем обновление в фоне
                Next
ErrorHandler: 'метка
                If Err.Number <> 0 Then 'если в объекте Err параметр Number не равен нулю, значит там есть данные по ошибке
                    FName = WO.Name 'короткая переменная пути к книге
                    CValue = TW.Sheets("Папки").Range("B" & Row).Value 'данные в ячейке, куда собираемся записывать
                    TW.Sheets("Папки").Range("B" & Row).Value = IIf(Len(CValue) = 0, FName, CValue & vbCrLf & FName): DoEvents 'записываем данные в ячейку, проверяем - если сначала пусто, то просто записываем имя файла, если есть данные, то добавляем перенос строки
                    Err.Clear 'очищаем данные в объекте по ошибкам
                End If
                Application.AskToUpdateLinks = True
                WO.Close True 'закрываем книгу с сохранением
                Set WO = Nothing 'уничтожаем объект-переменную
End Sub

Sub Refresh_All_Files_in_Folder()
    Dim lTest As Long, cn As WorkbookConnection
     
    WORK_FOLDER = "C:\Users\roman\Downloads\"       'путь к папке с файлами (должен заканчиваться на обр.слэш!)
     
    'получаем список всех файлов из папки в массив
    CurPath = Dir(WORK_FOLDER & "*.xlsx", vbNormal)
    i = 0
     
    'перебираем по очереди все файлы в папке
    Do Until CurPath = ""
        i = i + 1
        'открываем очередной файл
        Workbooks.Open Filename:=WORK_FOLDER & CurPath, ReadOnly:=False
         
         
        'обновляем всё запросы PQ и дожидаемся загрузки новых данных
        For Each oc In ActiveWorkbook.Connections
                 oc.OLEDBConnection.BackgroundQuery = False
            oc.Refresh                  
        oc.OLEDBConnection.BackgroundQuery = True
        Next
         
        
        'обновляем сводные
        ActiveWorkbook.RefreshAll
 
         
        'закрываем файл
        ActiveWorkbook.Close SaveChanges:=True
         
        'переходим к следующему файлу
        CurPath = Dir()
    Loop
     
    MsgBox "Обновлено " & i & " файлов"
 
 
End Sub

Sub SaveFile()

   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String

   Application.DisplayAlerts = False
   Path = ThisWorkbook.Path & "\"
   CellValue = Range("B14")
   FinalFileName = Path & CellValue
   ActiveWorkbook.SaveAs FileName:=FinalFileName, _
                      FileFormat:=xlOpenXMLWorkbook

  End Sub