Sub CellSelection()
    Dim RezPoiska As Range, firstAddress$
    Set RezPoiska = Cells.Find(What:="Телевидение", LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    If RezPoiska Is Nothing Then Exit Sub
    firstAddress = RezPoiska.Address
    RezPoiska.Select
    Do
        Set RezPoiska = Cells.FindNext(RezPoiska)
        If RezPoiska.Address = firstAddress Then Exit Do
        Union(Selection, RezPoiska).Select
    Loop
    
'   Selection.Select
'   Selection.Offset(0, 0).Resize(Selection.Rows.Count, _
'   Selection.Columns.Count + 2).Select
    
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
            
End Sub