Sub импорт()
      On Error GoTo Errors1'обработок ошибок
      Dim wb As Workbook, FName
      ChDrive Mid(ThisWorkbook.Path, 1, 1)
      FName = Application.GetOpenFilename("Excel Files, *.xls*", , "Выберите файл")
      If FName = False Then Exit Sub'если нажали ОТМЕНА, тогда выходим
      Application.ScreenUpdating = 0
      Set wb = GetObject(FName)'открываем файл скрыто
      If wb.Name = ThisWorkbook.Name Then Exit Sub'если имя открываемого файла совпадает с этим файлом, тогда выходим
      Set c = wb.Worksheets("Лист1").Range("A1:K20").Find("Товар", LookIn:=xlValues)    'Диапазон ячеек ГДЕ ищем
      If Not c Is Nothing Then
          Application.Goto c, True
          With ThisWorkbook.Worksheets("Отчет")
              .Cells(4, 2).Value = Cells(ActiveCell.Row, ActiveCell.Column + 1).Value    'Row +  - адрес от критерия
              .Cells(1, 2).Value = wb.Name'имя файла
              .Cells(2, 2).Value = wb.Path'путь файла
          End With
      Else: ud
      End If
      ThisWorkbook.Activate
      If IsFileOpen(wb.Name) = True Then wb.Close 0'если файл открыть, тогда закрываем без сохранении
      GoTo Ends:
Errors1:
      ud
Ends:
      Application.ScreenUpdating = 1
End Sub
'функция: узнаем открыта ли файл
Function IsFileOpen(FilePathName As String) As Boolean
      Dim FN%
      FN = FreeFile
      On Error Resume Next
      Open FilePathName For Random Access Read Write Lock Read Write As FN
      Close FN
      IsFileOpen = Err <> 0
End Function

Sub ud()
      With ThisWorkbook.Worksheets("Отчет")
          .Cells(1, 2).Value = "": .Cells(2, 2).Value = ""
          .Cells(4, 2).Value = ""
          .Cells(4, 2).Value = ""
      End With
End Sub

Sub get1()
'On Error GoTo Errors1 'обработок ошибок
Dim wb As Workbook, FName, FPath
FName = Cells(1, 2).Value & ".xlsx" 'имя файла
FPath = Cells(2, 2).Value 'путь к файлу
'
If Cells(1, 2).Value = "" Or Cells(1, 2).Value = "" Then Exit Sub
Application.ScreenUpdating = 0
'проверяем открыть ли файл: если нет, тогда открываем
If IsFileOpen(FPath & "\" & FName) = False Then
Set wb = GetObject(FPath & "\" & FName) 'открываем скрыто
Else: Set wb = Workbooks(FName)
End If
'если имя файла соовпадает с этим файлом, тогда выходим
If wb.Name = ThisWorkbook.Name Then Exit Sub

Set c = wb.Worksheets("Лист1").Range("A1:K20").Find("Заемщик", LookIn:=xlValues) 'Диапазон ячеек ГДЕ ищем
If Not c Is Nothing Then
Application.GoTo c, True
With ThisWorkbook.Worksheets("Отчет")
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row + 3, ActiveCell.Column + 1)).Copy _
Destination:=.Cells(4, 2) 'копируем данные
End With
Else: ThisWorkbook.Worksheets("Отчет").Range("B4:B6").Value = ""
End If
ThisWorkbook.Activate
'закрываем файл без сохранении
'wb.Close 0
'если где та вылетить ошибка, тогда очищаем данные с ячеек "B4:B6"
GoTo Ends:
Errors1:
ThisWorkbook.Worksheets("Отчет").Range("B4:B6").Value = ""
Ends:
Application.ScreenUpdating = 1
End Sub

'не удалять функцию: проверка открыта ли файл
Function IsFileOpen(FilePathName As String) As Boolean
Dim FN%
FN = FreeFile
On Error Resume Next
Open FilePathName For Random Access Read Write Lock Read Write As FN
Close FN
IsFileOpen = Err <> 0
End Function

Sub get2()
Set c = Workbooks(Cells(4, 4) & ".xlsx").Worksheets("Резюме").Range("A6:AY20").Find("Программа кредитования:", LookIn:=xlValues) 'Диапазон ячеек ГДЕ ищем
If Not c Is Nothing Then
Application.GoTo c, True
With ThisWorkbook.Worksheets("Compare")
Cells(ActiveCell.Row, ActiveCell.Column + 12).Copy _
Destination:=.Cells(19, 3) 'копируем данные
End With
Else: ThisWorkbook.Worksheets("Compare").Range("C19").Value = ""
End If
ThisWorkbook.Activate
'если где та вылетить ошибка, тогда очищаем данные с ячеек "C18"
GoTo Ends:
Errors1:
ThisWorkbook.Worksheets("Compare").Range("C19").Value = ""
Ends:
Application.ScreenUpdating = 1
End Sub