=ИНДЕКС(E:E;ПОИСКПОЗ(1;ПОИСК(E:E;A1);0))

Sub Категории()
    Dim err As Variant
    err = Sheets("Лист2").Range("E1:E7")
    
    Dim r As Range
    Dim y As Long
    With ActiveSheet
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set r = .Range(.Cells(1, 1), .Cells(y, 2))
    End With
    
    Dim arr As Variant
    arr = r
    
    Dim u As Long
    For y = 1 To UBound(arr, 1)
        For u = 1 To UBound(err, 1)
            If InStr(LCase(arr(y, 1)), LCase(err(u, 1))) > 0 Then
                arr(y, 2) = err(u, 1)
                Exit For
            End If
        Next
    Next
    r = arr
End Sub