Sub Импорт()
MsgBox "Внимание!!!Необходимо выбрать уже заполненный файл.  следуйте инструкции!"
     
Dim BazaWb As Workbook 'файл для сбора данных
Dim BazaSht As Worksheet 'лист в файле для сбора данных
Dim SelectedItem As String 'имя файла выбранного в диалоге
Dim oAwb As String 'имя открытой книги

With Application
'отлючаем обновление экрана - это убыстрит работу макроса
.ScreenUpdating = False
'включаем ручной пересчёт формул - это убыстрит работу макроса
.Calculation = xlManual
'отключаем отображения окон на панели задач на время выполнения макроса
.ShowWindowsInTaskbar = False
'присваиваем переменной BazaWb ссылку на общий файл
Set BazaWb = ActiveWorkbook
   'включаем автоматический пересчёт формул, который отключили в начале макроса
.Calculation = xlAutomatic
'включаем отображения окон на панели задач, которое отключали в начали макроса
.ShowWindowsInTaskbar = True
'включаем обновление экрана, который отключили в начале макроса
.ScreenUpdating = True

       
'вызываем диалог выбора папки с файлами отчёта
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Выберите файл для отчета" 'надпись в окне диалога
   'путь по умолчанию к папке /где расположен исходный файл
.InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xlsx*"
.AllowMultiSelect = False 'запрет выбора нескольких файлов
If .Show = False Then GoTo ErrExt:
'For Each SelectedItem In .SelectedItems 'перебор файлов в папке
SelectedItem = .SelectedItems(1) 'при обработке нескольких - удалить
oAwb = Dir(SelectedItem, vbDirectory) 'запоминаем имя книги
Workbooks.OpenText SelectedItem 'открываем книгу
'операции с открытой книгой
With ActiveWorkbook
'перебор заданных листов для копирование
.Sheets("Свод").Copy Before:=BazaWb.Sheets(1)
.Sheets("Прил2").Copy Before:=BazaWb.Sheets(8)
.Sheets("Прил4").Copy Before:=BazaWb.Sheets(9)
.Sheets("таблица категорий").Copy Before:=BazaWb.Sheets(10)
End With
Workbooks(oAwb).Close False 'закрываем книгу
'Next SelectedItem
End With
ErrExt:
End With
MsgBox "Необходимые листы скопированы, для проверки отчёта необходимо перейти на Рабочий лист"
End Sub

Sub Импорт()
     Dim BazaWb As Workbook    'файл для сбора данных
     Dim SelectedItem As String    'имя файла выбранного в диалоге

     MsgBox "Внимание!!!Необходимо выбрать уже заполненный файл.  следуйте инструкции!"

     'вызываем диалог выбора папки с файлами отчёта
     With Application.FileDialog(msoFileDialogFilePicker)
         .Title = "Выберите файл для отчета"    'надпись в окне диалога
         'путь по умолчанию к папке /где расположен исходный файл
         .InitialFileName = ThisWorkbook.Path & Application.PathSeparator & "*.xlsx*"
         .AllowMultiSelect = False    'запрет выбора нескольких файлов
         If .Show = False Then GoTo ErrShow:
         SelectedItem = .SelectedItems(1)    'при обработке нескольких - удалить
     End With
     With Application
         'отлючаем системные сообщения
         .DisplayAlerts = False
         'отлючаем обновление экрана - это убыстрит работу макроса
         .ScreenUpdating = False
         'включаем ручной пересчёт формул - это убыстрит работу макроса
         .Calculation = xlManual
         'отключаем отображения окон на панели задач на время выполнения макроса
         .ShowWindowsInTaskbar = False
     End With
     'присваиваем переменной BazaWb ссылку на общий файл
     Set BazaWb = ThisWorkbook
     With Workbooks.Open(SelectedItem)
         On Error Resume Next
         'операции с открытой книгой
         'перебор заданных листов для копирование
         .Sheets("Свод").Cells.Replace What:="=", Replacement:="|", LookAt:=xlPart, SearchOrder _
                    :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         .Sheets("Свод").Copy Before:=BazaWb.Sheets(1)
         .Sheets("Прил2").Copy Before:=BazaWb.Sheets(2)
         .Sheets("Прил4").Copy Before:=BazaWb.Sheets(3)
         .Close False    'закрываем книгу
     End With
     Sheets("Свод").Cells.Replace What:="|", Replacement:="=", LookAt:=xlPart, SearchOrder _
                    :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
     Sheets("Свод").Activate
     MsgBox "Необходимые листы скопированы"    ', для проверки отчёта необходимо перейти на Рабочий лист"
     On Error GoTo 0
ErrShow:
     With Application
         'включаем автоматический пересчёт формул, который отключили в начале макроса
         .Calculation = xlAutomatic
         'включаем отображения окон на панели задач, которое отключали в начали макроса
         .ShowWindowsInTaskbar = True
         'включаем обновление экрана, который отключили в начале макроса
         .ScreenUpdating = True
         .DisplayAlerts = False
     End With
End Sub