Sub www()
    Dim oTbl As ListObject, cell As Range, trg As Range, s$
    Application.ScreenUpdating = False
    For Each trg In Sheets("Лист1").ListObjects("Таблица1").DataBodyRange.Columns(1).Cells
        For Each oTbl In Sheets("Лист2").ListObjects
            For Each cell In oTbl.DataBodyRange.Columns(1).Cells
                If trg.Value Like "*" & cell.Value & "*" Then
                    s = oTbl.HeaderRowRange.Cells(1)
                    Select Case s
                    Case "Сельхоз", "Производство"
                        trg.Offset(, 1) = s
                    Case "Дерево", "Фрукт", "Инструмент"
                        trg.Offset(, 2) = s
                    End Select
                End If
            Next cell
        Next oTbl
    Next trg
    Application.ScreenUpdating = True
End Sub