Public Sub seach
'макрос-поисковик
'sm, pom, sg, pog, s, po - переменные задающие границы поиска по датам
Dim sm, pom, sg, pog, s, po As Integer
'cat - переменные отвечающие за выбор категории (искомые значения)
'Dim cat1, cat2, cat3 As String
Dim sh As Worksheet, oTbl As ListObject, x, Poz&
Dim PctDone As Double
'не отображать на экране промежуточные действия
Application.ScreenUpdating = False

'определение области построения и ее очистка
Set oTbl = ActiveSheet.ListObjects("Таблица1")
With oTbl
With .DataBodyRange
.ClearContents
If .Rows.Count > 1 Then .Rows(2).Resize(.Rows.Count - 1).Delete
End With

'определение переменных
Poz = 1
'для выбора категорий поиска
cat1 = Range("R1")
cat2 = Range("R2")
cat3 = Range("R3")
'для определения диапазона просматриваемых листов в книге
sm = Range("B2")
pom = Range("B3")
sg = Range("C2")
pog = Range("C3")
s = Worksheets(sm & "." & sg).Index
po = Worksheets(pom & "." & pog).Index

'заполнение таблицы искомыми значениями
For Each sh In Worksheets
If sh.Index >= s And sh.Index <= po Then
x = sh.Range("A3", sh.Cells(sh.Rows.Count, 10).End(xlUp)).Value
For i = 1 To UBound(x)
If x(i, 2) = cat1 or x(i, 2) = cat2 or x(i, 2) = cat3 Then
If Poz > 1 Then .ListRows.Add
With .DataBodyRange
.Cells(.Rows.Count, 1) = Poz
.Cells(.Rows.Count, 2) = x(i, 2)
.Cells(.Rows.Count, 3) = x(i, 3)
.Cells(.Rows.Count, 4) = x(i, 4)
.Cells(.Rows.Count, 5) = x(i, 5)
.Cells(.Rows.Count, 6) = x(i, 6)
.Cells(.Rows.Count, 7) = x(i, 7)
.Cells(.Rows.Count, 8) = x(i, 8)
.Cells(.Rows.Count, 9) = x(i, 9)
.Cells(.Rows.Count, 10) = x(i, 10)
End With
Poz = Poz + 1
End If
PctDone = i / UBound(x)
Call UpdateProgress(PctDone)
Next i
End If
Next sh
End With
Application.ScreenUpdating = True
MsgBox ("Данные обновленны!")
End Sub