Sub KeyWord()
Dim Sht As Worksheet
Dim i As Long
Dim n As Integer
Dim FoundCell As Range
Dim FAdr As String
Application.ScreenUpdating = False
    i = 6
    n = 3   'для трех ключевых слов
  For Each Sht In Worksheets
    If Sht.Name <> "ПОИСК" Then        ' кроме листа "ПОИСК"
      With Sht
       Set FoundCell = .UsedRange.Find(Range("D6"), , xlValues, xlPart)
        If Not FoundCell Is Nothing Then  'нашли ячейку с первым ключевым словом
           FAdr = FoundCell.Address       'запоминаем адрес этой ячейки
         Do             'проверяем есть ли в ячейке второе и третье ключевое слово
           If InStr(1, FoundCell, Range("D7")) <> 0 And InStr(1, FoundCell, Range("D8")) <> 0 Then
             Cells(i, "H") = n
             Cells(i, "I") = FoundCell
             i = i + 1
           End If
             Set FoundCell = .UsedRange.Find(Range("D6"), After:=FoundCell)
         Loop While FoundCell.Address <> FAdr
        End If
      End With
    End If
    Set FoundCell = Nothing
  Next
Application.ScreenUpdating = True
End Sub