Sub Поиск()
Dim iFoundRng As Range, iRow As Long
Dim iDataWb As Workbook, TmpWb As Workbook, FoundFlag As Boolean
Dim MsgResult As VbMsgBoxResult, iTempSht As Worksheet, iListSht As Worksheet


'("Чистый") имя листа с которого начинаем сверять данные с базой
 '("A2") ячейка ("A2")с которой начинаем поиск в "Чистый"
 '("A:A") столбещ в фале с базой в которой ищем то что сверяем с данными из "Чистый"
 '("A") то что сверяем с данными из "Чистый"


 '("A") куда копируем в лист "Чистый" и "Отсутствует" если ненашли пишем Отсутствует
 ' "A" откуда копируем данные (из БАЗЫ) столбец К если нашли что либо

 'Вставляем новые столбцы

 'скрываем отображение
Application.ScreenUpdating = False

 

 'перебираем все открытые книги в поиске файла Табл Данных

For Each TmpWb In Workbooks
 If Not TmpWb.Name = ThisWorkbook.Name And TmpWb.Name <> "PERSONAL.XLS" Then
 MsgResult = MsgBox(TmpWb.Name, vbYesNoCancel + vbDefaultButton2 + vbQuestion, "Укажите файл Данных")
 If MsgResult = vbCancel Then Exit Sub
 If MsgResult = vbYes Then
 Set iDataWb = Workbooks(TmpWb.Name)
 Exit For
 End If
 End If

 Next TmpWb
 Set TmpWb = Nothing
 Set iListSht = ThisWorkbook.Worksheets("Чистый")
'("Чистый") имя листа с которого начинаем сверять данные с базой
FoundFlag = False

 With iListSht
 For iRow = 2 To .Range("A2").End(xlDown).Row
'("A2") ячейка ("A2")с которой начинаем поиск в
For Each iTempSht In iDataWb.Worksheets
 Set iFoundRng = iTempSht.Range("A:A").Find(iListSht.Cells(iRow, "A"), , xlFormulas, xlWhole)
'("A:A") столбещ в фале с базой в которой ищем то что сверяем с данными из "Чистый"
 '("A") то что сверяем с данными из "Чистый"
If Not iFoundRng Is Nothing Then
 FoundFlag = True
 .Cells(iRow, "B") = iTempSht.Cells(iFoundRng.Row, "B")
 
'("A") куда копируем в лист "Чистый"
 ' "A" откуда копируем данные (из БАЗЫ) столбец А если нашли что либо

End If
 Next iTempSht
 If FoundFlag = False Then iListSht.Cells(iRow, "B") = " Отсутствует "

' "A") = "Отсутствует" если ненашли пишем Отсутствует

FoundFlag = False
 Next iRow
 End With
 Application.ScreenUpdating = True

 'MsgBox "Конец", vbInformation, "Конец"

End Sub