Sub CopyAllBook()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CutCopyMode = False
Dim wb As Workbook
q = ThisWorkbook.Path

'открываем все книги в папке рабочие (там храним файлы от регионов)
Dim MyName As String
Dim MyPath As String
Dim sPath As String ' тут вставил
      MyPath = ThisWorkbook.Path & "\ПРИНЯЛ\"
      MyName = Dir(MyPath & "*.xlsx")
       Do While MyName <> ""
          sPath = MyPath + MyName
          Excel.Application.Workbooks.Open sPath
          IPATH = q & "\ПРАВИЛЬНО\" & ActiveWorkbook.Worksheets("ИМЯ").Range("A1").Value
          ActiveWorkbook.SaveAs Filename:=IPATH, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
          Excel.Application.ActiveWorkbook.Close
          MyName = Dir
       Loop
         
Application.CutCopyMode = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub