Sub НайтиИФильтровать()
Application.DisplayAlerts = False
Call ScreenOff

Dim НачЯч As Range
Dim Диап As Range
Dim Столб As Range
Dim Строк As Range
Dim СтартАдр As String ' Хранит координаты первого найденного значения
Dim Результат As Range
Dim Искомое As String
Dim НачЯчАдр As String
Dim ИскЯч As Range
Dim КолСтр As Integer
Dim Цвет As Integer
Set НачЯч = ActiveCell
НачЯчАдр = ActiveCell.Address
Set Столб = Range(Cells(1, ActiveCell.Column), _
Cells(Range("A65536:IV65536").End(xlUp).Row, ActiveCell.Column))

Искомое = "*" & InputBox("Чаво искать будем?") & "*"
' Поиск первого входжения искомого слова
Set Результат = Столб.Find(Искомое, , , xlWhole)
If Not Результат Is Nothing Then
' Сохраним адрес найденной ячейки (чтобы контролировать зацикливание поиска)
СтартАдр = Результат.Address
End If
Do While Not Результат Is Nothing
' Обработка результата поиска
Результат.Interior.ColorIndex = 20
Результат.Font.ColorIndex = 5

' Новый поиск
Set Результат = Столб.FindNext(Результат)
If Результат.Address = СтартАдр Then ' Поиск завершен
Exit Do
End If
Loop
Dim АктСтолб
КолСтр = Столб.Rows.Count
АктСтр = НачЯч.Row
Цвет = 20
НачЯч.Select
АктСтолб = НачЯч.Column
For I = АктСтр To КолСтр
If Cells(I, АктСтолб).Interior.ColorIndex <> Цвет Then
Rows(I).Hidden = True
End If
Next
Application.DisplayAlerts = True
Call ScreenOn
End Sub

Sub Разфильтровать()
Call ScreenOff
Dim Столб As Range
Dim КолСтр As Integer
Dim КонСтр
Dim НомСтолб As Integer
Set Столб = Range(Cells(1, ActiveCell.Column), _
Cells(Range("A65536:IV65536").End(xlUp).Row, ActiveCell.Column))
КолСтр = Столб.Rows.Count
КонСтр = Range("A65536:IV65536").End(xlUp).Row
НомСтолб = Столб.Column

For I = 1 To КонСтр
Cells(I, НомСтолб).Interior.ColorIndex = xlNone
Cells(I, НомСтолб).Font.ColorIndex = 1
Next

For I = 1 To КолСтр
If Rows(I).Hidden = True Then
Rows(I).Hidden = False
End If
Next
Call ScreenOn
End Sub