Sub Find_Words()
Dim arr As Variant
Last_Column = Sheets("1").UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
Last_Row = Sheets("1").Range("A" & Rows.Count).End(xlUp).Row
arr = Sheets("1").Range("A1").Resize(Last_Row, Last_Column)
For i = 1 To UBound(arr)
    If Len(arr(i, 3)) > 3 Then
       If Right(arr(i, 3), 2) = "ая" Then
       arr(i, 3) = Mid(arr(i, 3), 1, Len(arr(i, 3)) - 2)
       End If
   End If
Next i

Sheets("2").Select
total_rows = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To total_rows
    For j = LBound(arr) To UBound(arr)
        s = InStr(1, Cells(i, 2), arr(j, 3))
        If s Then
            Cells(i, 5) = arr(j, 1)
        End If
    Next j
Next i

End Sub

Sub Find_Words()
Dim arr As Variant
With Sheets("1")
Last_Column = .Cells(1, .Columns.Count).End(xlToLeft).Column
Last_Row = .Range("A" & .Rows.Count).End(xlUp).Row
arr = .Range("A1").Resize(Last_Row, Last_Column + 1)
End With
For i = 1 To UBound(arr)
    If Len(arr(i, 3)) > 5 Then
       arr(i, 4) = Mid(arr(i, 3), 1, 5)
   End If
Next i
Sheets("2").Select
total_rows = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To total_rows
    For j = LBound(arr) To UBound(arr)
        s = InStr(1, Cells(i, 2), arr(j, 3))
        If s Then
            Cells(i, 5) = arr(j, 1)
            Else
            If InStr(1, Cells(i, 2), arr(j, 4)) > 0 And arr(j, 4) <> "" Then
             Cells(i, 5) = arr(j, 1)
            End If
        End If
    Next j
Next i

End Sub